http://dieseyer.de • all rights reserved • © 2011 v11.4

'v6.1 ==========================================================================================
'
' NAME: text-in-80-zeichen-je-zeile.vbs
'
' AUTOR: Michael Wende - wende@helimail.de
' dieseyer.de
' DATUM: 08.01.06
'
' KOMMENTAR: Übernimmt man markierten Text aus dem Internet-Browser z.B. in Notepad,
' stören oft die fehlenden Zeilenümbrüche (Zeilen mit mehr als 100 Zeichen).
' Um die Darstellung auf max. 80 Zeichen pro Zeile zu begrenzen, entstand
' dieses Skript.
'
' Arbeitsweise:
' Das Skript liest eine Datei ein und speichert diese mit max. 80 Zeichen
' pro Zeile. Die temporäre (Ausgabe-) Datei hat den Namen der Ursprungsdatei,
' wobei am Ende des Dateinamens (ohne Erweiterung) ein Kleinbuchstabe a ... z
' angehängt wird. Zum Schluß wird die Ursprungsdatei durch die temporäre Datei
' überschrieben.
'
'==================================================================================================

Dim myfsObject,textziel, thefiles
Public outfile,arg,strTitleText,strErrText

Set myfsObject=CreateObject("Scripting.FileSystemObject")
Set oFs=CreateObject("Scripting.FileSystemObject")
Set thefiles = CreateObject("Scripting.Dictionary")

arg = BrowseForFile("Bitte (Text)Datei auswählen!","Dateiwahl")
If arg = "" Then
WScript.Quit
End If

If Mid(arg,Len(arg),Len(arg))= "\" then ' Ist Backslash am Ende,dann OK
textziel = arg
Else
textziel = arg & "\" ' sonst Backslash anhängen
End If
' Scripting.Dictionary Anwendung:
thefiles.Add "a", arg ' nimmt die Ursprungsdatei in "a" und
thefiles.Add "b",readFile(arg) ' die umformatierte Datei in "b" auf

On Error Resume Next

oFs.CopyFile thefiles.Item("b"), thefiles.Item("a"),True
If Err.Number Then
strTitleText = "Es ist mir unmöglich die Datei zu kopieren"
strErrText = "Fehler beim Kopieren von '" & thefiles.Item("b") & "' nach '" & thefiles.Item("a") & "'" & vbCRLF & vbCRLF
strErrText = strErrText & "VBScript Fehler ist aufgetreten:" & vbCRLF
strErrText = strErrText & "Fehlernr. = " & Err.Number & vbCRLF
strErrText = strErrText & "Fehlerbeschreibung: = " & Err.Description & vbCRLF
strErrText = strErrText & "Kontexthilfe = " & Err.Helpdcontext & vbCRLF
strErrText = strErrText & "Hilfepfad = " & Err.Helppath & vbCRLF
strErrText = strErrText & "eigentlicher Fehler = " & Err.Nativeerror & vbCRLF
strErrText = strErrText & "Quelle = " & Err.Source & vbCRLF
MsgBox strErrText, vbOKOnly + vbInformation, strTitleText
Err.Clear
End If


MsgBox "Alle Dateisätze verarbeitet.Programm wird beendet."

' Ende des Programmes

' ********* Start Funktionen und Unterprogramme (Subs) **********************************************************

Public Function WordWrap(ByVal strText, ByVal Laenge)
If isNumeric(Laenge) Then
If Laenge > 0 Then
If len(strText) > Laenge Then
WordWrap = left(strText, instrrev(strText," ",Laenge)) '-1)
Else
WordWrap = strText
End If
End If
End If
End Function


Public Function readFile(fname)
Dim Insatz,oFS,oFile,inputfile,neudatei
Dim reststring,restlaenge,rz,copyofinsatz,Insatzlen

outfile=MakeNewFile (fname) ' Ausgabedatei erstellen
neudatei=outfile
Set oFS = CreateObject("Scripting.FileSystemObject")
Set outfile=oFS.CreateTextFile(outfile, 1) ' Ausgabedatei öffnen
Set oFile = oFS.GetFile(fname)
Set inputfile = oFile.OpenAsTextStream ' Eingabedatei öffnen

do while not inputfile.AtEndOfStream ' bis Ende Eingabedatei lesen und neue Ausgabedatei erstellen und
Insatz = inputfile.ReadLine ' mit 80 Zeichen pro Zeile beschreiben.
Insatzlen = Len(Insatz)
copyofinsatz = Insatz
restlaenge=0 : reststring="" : rz=0

While rz < (Insatzlen-1)
reststring=WordWrap(copyofinsatz,80)
outfile.WriteLine reststring '& vbCrlf würde zusätzliche Leerzeilen schaffen
rz = rz + Len(reststring)
restlaenge = Insatzlen - rz

If restlaenge = 0 Then
' tue nichts
else
copyofinsatz = Mid(Insatz,rz+1,restlaenge)
End If
reststring=""
Wend

Loop
outfile.Close
readFile=neudatei
End Function


Function MakeNewFile (Quelldatei)
' Erstellt aus dem Namen einer Quelldatei einen neuen Namen. Gebraucht man,wenn man zum Beispiel eine
' Datei aktualisiert hat, aber ihre Ursprungsdaten erhalten will.
' An den Dateinamen wird beim ersten Aufruf ein Kleinbuchstabe a angehängt.
'
' Beispiel: Quelldatei C:\Texte\Einladung1.doc
' wird zu: C:\Texte\Einladung1a.doc
'
' Existiert die Zieldatei C:\Texte\Einladung1a.doc schon, wird an die Zieldatei Der Kleinbuchstabe ( b ... z)
' (also C:\Texte\Einladung1b.doc u.s.w.) angehängt.
' Max. 26 Variationen einer Quelldatei sind somit möglich.


Dim fs,intZaehler,DateiN
Dim nameneu,DateiEndung
'Dim Dname

Set fs = CreateObject("Scripting.FileSystemObject")
'Dname = fs.GetDriveName(Quelldatei) ' So könnte ich das Laufwerk ausfiltern
'DateiN = fs.objFSO.getFileName(Quelldatei) ' So könnte ich den Dateinamen ausfiltern
Pfad=fs.GetParentFolderName(Quelldatei) ' Dateipfad ausfiltern

For intZaehler = 97 to 122 ' von a - z Chr(97) = a
DateiN=fs.GetBaseName(Quelldatei) ' Dateiname ohne Endung ausfiltern
DateiEndung = fs.GetExtensionName(Quelldatei) ' Dateiendung
nameneu = Pfad & DateiN & Chr(intZaehler) & "." & DateiEndung
If not fs.FileExists(nameneu) Then
MakeNewFile=nameneu
Exit Function
End If
Next
End Function


Function BrowseForFile(strPrompt,strtitle)
'Benutzt die "Shell.Application" (nur anzutreffen in Win98 and neuer)
'um das Datei/Ordner Fenster aufzurufen. Nicht unter Win95.
'Shell32.ShellSpecialFolderKonstanten
Const ssfPERSONAL = 5 'Meine Dokumente
Const ssfDRIVES = 17 'Mein Computer
Const SFVVO_SHOWALLOBJECTS = 1
Const SFVVO_SHOWEXTENSIONS = 2
Const SFVVO_SHOWFILES = 16384
Dim sh, fol, fs, lngView, strPath,i
Set sh = CreateObject("Shell.Application")
If Instr(TypeName(sh), "Shell") = 0 Then
BrowseForFile = InputBox(strPrompt, strtitle, CreateObject("Scripting.FileSystemObject").GetParentFolderName(WScript.ScriptFullName) & "Pfad\Dateiname")
Exit Function
End If
Set fs = CreateObject("Scripting.FileSystemObject")
lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS Or SFVVO_SHOWFILES
strPath = ""
Set fol = sh.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
On Error Resume Next
strPath = fol.ParentFolder.ParseName(fol.Title).Path
If strPath = "" Then
strPath = fol.Title
Set fol = fol.ParentFolder
strPath = fs.BuildPath(fol.ParentFolder.ParseName(fol.Title).Path, strPath)
i = InStr(strPath, ":")
strPath = Mid(strPath, i - 1, 1) & ":\" ' Nur Laufwerk:\ zurückgeben
End If
BrowseForFile = strPath
End Function

' ********* Ende Funktionen und Unterprogramme (Subs) **********************************************************

http://dieseyer.de • all rights reserved • © 2011 v11.4