Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
Ein Programm in der Programmiersprache A program in the programming language
vbScript
zur Entfernung von Zeilenumbrüchen in einem Text to remove linebreaks in a text

Das folgende Programm, in eine Textdatei geschrieben und mit der Dateierweiterung "ProgrammName.vbs" ausgestattet, ist gemacht, um es in einen Ordner zu bewegen, in dem sich die zu bearbeitenden Dateien befinden. Das Programm wird in einer Windows-Umgebung mit einem Doppelklick gestartet und entfernt in allen Dateien dieses Ordners, die durch ein Datei-Erweiterungs-Filter durchgelassen werden, z.B. allen *.txt-Dateien, die Zeilenumbrüche, läßt Absätze unverändert und schreibt die Ergebnisse unter gleichem Dateinamen in einen Unterordner mit dem Namen "Out".

The following program, written into a text-file and equipped with the extension "program.vbs", is made to move it into a folder, in which there are the files to process. The program, startet in a Windows-environment by a double-click, removes in all files of this folder, which are left through by an file-extension-filter, for example all "*.txt"-files, the linebreaks, leaves paragraphs unchanged and writes the results under the same filename into a subfolder with the name "Out".

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
The program ist tested before publication, but there can be given no guarantee, that it is free of errors
2. Aug. 2012 Aug 2nd 2012

' Remove line-breaks out of a text and leave paragraphs unchanged
' The path of the text-files is expected to be in the same directory as the script

' Single CrLf will be replaced by blanks,
' If more than 1 CrLf subsequent, all will be left

Option Explicit

' Constants, Variables + Objects

Const ForReading=1, ForWriting=2 ' Constants
Dim WshShell, fso, f, fc, f1 ' Ojects
Dim MyCurrentPath, ChosenFile, Path, FileName, Ext, OutFolder, Text, ExtensionFilter, MsgText ' Strings

' Assignments

Set fso = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
MyCurrentPath = WshShell.CurrentDirectory & "\" ' WshShell.CurrentDirectory = without Backslash

' User-Parameter-Settlings

OutFolder = "Out\"
ExtensionFilter = ".txt"

' Program

Set f = fso.GetFolder(MyCurrentPath)
Set fc = f.Files: MsgText = ""
For Each f1 In fc
    ChosenFile = MyCurrentPath & f1.Name
    If FileNameValid (ChosenFile, ExtensionFilter) Then
        If fso.FileExists(ChosenFile) Then
            ReadWriteTextFile ForReading, Text, ChosenFile
            If Text <> "" Then
                Text = ReplaceSingleCrLf (Text)
                SplitFileSpec ChosenFile, Path, FileName, Ext
                If fso.FolderExists(Path & OutFolder) = False Then
                    fso.CreateFolder(Path & OutFolder)
                End if
                ReadWriteTextFile ForWriting, Text, Path & OutFolder & FileName & Ext
                MsgText = "Procedure done"
            End If
        End If
    End If
Next: If MsgText = "" Then MsgText = "no valid file or text found"
MsgBox MsgText

' End of Program

' Procedures

Function ReplaceSingleCrLf (AnyText)
    'Replaces CrLf by a Blank if only one CrLf, more than one are left unchanged
    Dim CharPos, Char: CharPos = 0
    Do
        CharPos = CharPos + 1: Char = Mid(AnyText,CharPos,2)
        If Char = vbCrLf Then
            If CharPos <= 2 Then
                If Mid(AnyText,CharPos + 2,2) <> vbCrLf Then
                    AnyText = " " & Right(AnyText,Len(AnyText) - 2)
                    CharPos = CharPos - 1
                End If
            ElseIf CharPos = Len(AnyText) - 1 Then
                If Mid(AnyText,CharPos - 2,2) <> vbCrLf Then
                    AnyText = Left(AnyText,CharPos - 1) & " " & _
                    Right(AnyText,Len(AnyText) - CharPos - 1)
                    CharPos = CharPos - 1
                End If
            Else
                If Mid(AnyText,CharPos - 2,2)<> vbCrLf And _
                    Mid(AnyText,CharPos + 2,2)<> vbCrLf Then
                    AnyText = Left(AnyText,CharPos - 1) & " " & _
                    Right(AnyText,Len(AnyText) - CharPos - 1)
                    CharPos = CharPos - 1
                End If
            End If
            CharPos = CharPos + 1
        End If
    Loop Until CharPos => Len(AnyText) - 1
    ReplaceSingleCrLf = AnyText
End Function

Sub SplitFileSpec(ByVal AnyFileSpec, ByRef AnyPath, ByRef AnyFileName, ByRef AnyExt)
    Dim FulName
    AnyPath = Left(AnyFileSpec,InStrRev(AnyFileSpec,"\"))
    FulName = Mid(AnyFileSpec, Len(AnyPath) + 1)
    AnyFileName = Left(FulName, InStrRev(FulName,".") - 1)
    AnyExt = Mid(FulName, Len(AnyFileName) + 1)
End Sub

Function FileNameValid (AnyFileSpec, ListOfExtensions)
    ' ListOfExtensions for example ".eml.nws._eml._nws"
    Dim Ext, NoUse: FileNameValid = False
    SplitFileSpec AnyFileSpec, NoUse, NoUse, Ext
    If InStr (LCase(ListOfExtensions), LCase(Ext)) <> 0 Then FileNameValid = True
End Function

Sub ReadWriteTextFile(ByVal Direction, ByRef AnyText, ByVal AnyFileSpec)
    If Direction = ForReading Then
        AnyText = ""
        If fso.FileExists (AnyFileSpec) Then
            Set f = fso.OpenTextFile(AnyFileSpec, ForReading)
            AnyText = f.ReadAll: f.Close
        End If
    ElseIf Direction = ForWriting Then
        If fso.FileExists (AnyFileSpec) Then fso.DeleteFile(AnyFileSpec)
        Set f = fso.OpenTextFile(AnyFileSpec, ForWriting, True)
        f.Write AnyText: f.Close
    End if
End Sub

' End of Procedures