'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) **********************************************************