VBA (Word 2003) - Problemchen beim Ersetzen von Zeichen in allen Dateien eines Ordners

	X = X + 1

	MyDatei1.WriteLine (MyText(I))

	objword.quit

Dim FilterStr , PfadStr
Dim PfadStrNeu, DateiNameNeu
Dim Alt, Neu
Dim MyText()
Dim  X
Dim ZMAx

FilterStr = "*.*"  
X = 0
ZMax = 0


Set objWord = CreateObject("Word.Application")  
Set FSO = CreateObject("Scripting.FileSystemObject")  



PfadStr = inputbox("Bitte den kompletten Pfad zu dem zu durchsuchenden Ordner eingeben.","Pfadangabe...","C:\Test\")  
PfadStrNeu = PfadStr & "Test\"  
on error resume next
FSO.CreateFolder(PfadStrNeu)

Alt = inputbox("Bitte die zu ersetzende Zeichenkette eingeben...", "Alte Zeichenkette...", "altes")   
Neu = inputbox("Bitte die neue Zeichenkette eingeben...", "Neue Zeichenkette...", "neues")   

msgbox "Befehl wird ausgeführt! Bitte warten!",,"Mit Word...."  
objWord.FileSearch.FileName = FilterStr
objWord.FileSearch.LookIn = PfadStr
objWord.FileSearch.SearchSubfolders = False
objWord.FileSearch.Execute

objWord.Visible = False

FN = ""  
FNR = ""  

For Each objFile in objWord.FileSearch.FoundFiles	
	
	WScript.Echo "Oeffne Datei: " & ObjFile  

'Jetzt holen wir uns nur den Dateinamen raus	  
	FN = ""  
	FNR = ""  
	IFN = ""  
	IFNR = ""  
	for IFN = len(Objfile) to 0 Step -1
		FNTemp = mid (Objfile,IFN,1)
			If Not FNTemp = "\" then FN = FN & FNTemp  
			If FNTemp = "\" Then IFN = 0  
	next
'Hier wieder richtig rum drehen ;-)  
	for IFNR = len(FN) to 1 Step -1
		FNTempR = mid (FN,IFNR,1)
			FNR = FNR & FNTempR
	next

	
	ZMAx = 0
	Set MyDatei = FSO.OpenTextFile(objFile, 1)

'Zum bestimmen der maximalen Zeilenzahl in der einzulesenden Datei  
Do Until MyDatei.AtEndOfStream 
	TempText = MyDatei.ReadLine
	ZMAx = Zmax + 1 
Loop
MyDatei.close	
	
	WScript.Echo "Anzahl Zeilen: " & ZMAx  
	ReDim MyText(ZMax)


	Set MyDatei = FSO.OpenTextFile(objFile, 1)
Do Until MyDatei.AtEndOfStream 

	MyText(X) = MyDatei.ReadLine
	'WScript.Echo "Zeile " & X & ": Suche nach:'" & Alt & "' und ersetze durch:'" & Neu  
	MyText(X) = Replace(MyText(X), Alt, Neu)  
	X = X + 1  
Loop
	
MyDatei.close
	

	PfadNeu = PfadStrNeu & FNR ' & ".bak"  
	WScript.Echo "Daten werden nach " & PfadNeu & " geschrieben."  

	Set MyDatei1 = FSO.CreateTextFile(PfadNeu, TRUE)
	MyDatei1.Close
	Set MyDatei1 = FSO.OpenTextFile(PfadNeu, 8)
	for I = 0 to X
		MyDatei1.WriteLine (MyText(I))
	next
	MyDatei1.Close
	
	X = 0
Next


msgbox "Ferddich..."  

objword.quit

Set objword = nothing
Set MyDatei = nothing
Set FSO = nothing

Option Explicit

Const TitelOrdner = "Ordner-Pfadangabe"  
Const TitelTypen = "Datei-Typen"  
Const TitelSuchen = "Suchen"  
Const TitelErsetzen = "Ersetzen"  
Const TitelAktion = "Suchen und Ersetzen"  

Const MsgOrdner = "Bitte den Ordner-Pfad angeben: z.B. C:\Test"  
Const MsgTypen = "Bitte Dateitypen angeben: z.B. * oder rtf,html,..."  
Const MsgSuchen = "Bitte Zeichenkette angeben: Suchen nach..."  
Const MsgErsetzen = "Bitte Zeichenkette angeben: Ersetzen durch..."  

Const MsgAktion = "Soll der Ersetzenvorgang jetzt gestartet werden?  "  
Const MsgFertig = "Der Ersetzenvorgang ist abgeschlossen!."  

Const MsgFehler = "Die Eingaben sind unvollständig!"  

Dim Ordner, Typen, Suchen, Ersetzen, Fso, File, xFile, Extension, Text, i
    
Ordner = InputBox(MsgOrdner, TitelOrdner):  Typen = InputBox(MsgTypen, TitelTypen)
Suchen = InputBox(MsgSuchen, TitelSuchen):  Ersetzen = InputBox(MsgErsetzen, TitelErsetzen)
      
Set Fso = CreateObject("Scripting.FileSystemObject")  
    
If Fso.FolderExists(Ordner) = False Or Typen = "" Or Suchen = "" Then  
    MsgBox MsgFehler, vbExclamation, "Fehler":  WScript.Quit (1)  
End If
    
If MsgBox(MsgAktion & vbCr & vbCr & "Ordner:" & vbTab & " " & Ordner & vbCr & vbCr & _  
     "Typen:" & vbTab & " " & Typen & vbCr & vbCr & "Suchen:" & vbTab & " " & Suchen & vbCr & vbCr & _  
     "Ersetzen:" & vbTab & " " & Ersetzen, vbInformation Or vbOKCancel, TitelAktion) <> vbOK Then WScript.Quit (0)  
    
Typen = Split(Typen, ",")  
    
For Each File In Fso.GetFolder(Ordner).Files
    Extension = LCase(Fso.GetExtensionName(File.Name))
    For i = 0 To UBound(Typen)
        If Trim(Typen(0)) = "*" Then  
            If Extension = "txt" Or Extension = "rtf" Or Extension = "html" Then i = True: Exit For  
        Else
            If LCase(Trim(Typen(i))) = Extension Then i = True: Exit For
        End If
    Next
    
    If i = True Then
        Set xFile = Fso.OpenTextFile(File.Path)
        Text = Replace(xFile.ReadAll, Suchen, Ersetzen, 1, -1, vbTextCompare)
        Fso.CreateTextFile(File.Path).Write Text:  xFile.Close
    End If
Next

MsgBox MsgFertig, vbInformation, "Meldung":  WScript.Quit (0)  

Option Explicit

Const Name1 = "andreas"                 'Left  
Const Name2 = "linus"                   'Right  

Const HtmLeft = "left.Ht"  
Const HtmRight = "right.Ht"  
Const HtmPages = "pages.Ht"  

Const FdPages = "pages\"                'Unterordner  
Const FdImages = "images\"  
Const FdThumbnails = "thumbnails\"  

Const adVarChar = 200                   'Konstanten für ADO-Recordset  
Const adFldIsNullable = 32

Const Msg1 = "Die Erstellung der Htm-Dateien ist abgeschlossen."  

Const Err1 = "Die Ordnerstruktur ist fehlerhaft!"  
Const Err2 = "Htm-Vorlage (*.ht) nicht gefunden!"  
Const Err3 = "Die Image-Datei existiert nicht: "  

'*.ht = [Var $1 = Bild-Nr]  [Var $2 = Name]  [Var $3 = Width]  [Var $4 = Height]  

Dim Fso, JpgRec, P0, P1, P2, P3, TP, F1, F2, F3, TF, i

'Main Beg  
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    P0 = Fso.GetParentFolderName(WScript.ScriptFullName) & "\"  

    P1 = P0 & FdPages:  P2 = P0 & FdImages:  P3 = P0 & FdThumbnails
    
    TP = Array(P1, Name1, P1, Name2, P2, Name1, P2, Name2, P3, Name1, P3, Name2)
    
    For i = 0 To UBound(TP) Step 2
        If Fso.FolderExists(TP(i) & TP(i + 1)) = False Then MsgBox Err1, vbExclamation, "Fehler":  WScript.Quit  
    Next
    
    TF = Array(HtmLeft, HtmRight, HtmPages)
    
    For i = 0 To UBound(TF)
        If Fso.FileExists(P0 & TF(i)) = False Then MsgBox Err2, vbExclamation, "Fehler":  WScript.Quit  
    Next
    
    Call InitHtmFiles(Name1):  Call InitHtmFiles(Name2)
    
    MsgBox Msg1, vbInformation, "Meldung":  WScript.Quit  

'Main End  


Private Sub InitHtmFiles(ByRef User)
    Dim File, Text, Jpg, jpgNum, jpgInf
    
    On Error Resume Next
    
    Fso.DeleteFile (P1 & User & "\*.htm")  
    
    On Error GoTo 0
    
    Set File = Fso.OpenTextFile(P0 & HtmPages):  Text = File.ReadAll:  File.Close
    
    Call OpenJpgRec
    
    For Each Jpg In Fso.GetFolder(P3 & User).Files
        If LCase(Right(Jpg.Name, 4)) = ".jpg" Then  
            jpgNum = Fso.GetBaseName(Jpg.Name)
            jpgInf = GetJpgInfo(Jpg.Path)
            Call WriteJpgRec(jpgNum, User, jpgInf(0), jpgInf(1))
            Call CreatePagesFile(jpgNum, User, Text)
        End If
    Next
    
    If User = Name1 Then
        Call CreateControlFile(P0 & HtmLeft)
    ElseIf User = Name2 Then
        Call CreateControlFile(P0 & HtmRight)
    End If
End Sub
    
Private Sub CreatePagesFile(ByRef jpgNum, ByRef User, ByRef Text)
    Dim File, PathP, PathI, TextP, jpgInf
    
    PathP = P1 & User & "\" & jpgNum & ".htm"  
    
    PathI = P2 & User & "\" & jpgNum & ".jpg"  
    
    If Fso.FileExists(PathI) = False Then MsgBox Err3 & PathI, vbExclamation, "Fehler":  WScript.Quit  
    
    jpgInf = GetJpgInfo(PathI)
            
    TextP = GetVarText(Text, jpgNum, User, jpgInf(0), jpgInf(1))
    
    Set File = Fso.CreateTextFile(PathP):  File.Write TextP:  File.Close
End Sub

Private Sub CreateControlFile(ByRef Path)
    Dim File, Text, Line
    
    Set File = Fso.OpenTextFile(Path):  Text = Split(File.ReadAll, "#?#"):  File.Close  
    
    If UBound(Text) = 2 Then
        Set File = Fso.CreateTextFile(Path & "m"):  File.Write Text(0)  
        
        With JpgRec
           .Sort = "Num"  
           .MoveFirst
            Do Until .EOF
                Line = GetVarText(Text(1), .Fields(0), .Fields(1), .Fields(2), .Fields(3))
                File.WriteLine Line
               .MoveNext
            Loop
        End With
        
        File.Write Text(2)
    End If
    
    JpgRec.Close:  File.Close
End Sub

Private Sub OpenJpgRec()
    Set JpgRec = CreateObject("ADOR.Recordset")  
    With JpgRec.Fields
        .Append "Num", adVarChar, 32, adFldIsNullable  
        .Append "User", adVarChar, 32, adFldIsNullable  
        .Append "Width", adVarChar, 16, adFldIsNullable  
        .Append "Height", adVarChar, 16, adFldIsNullable  
         JpgRec.Open
    End With
End Sub

Private Sub WriteJpgRec(ByRef jpgNum, ByRef User, ByVal jpgWidth, ByVal jpgHeight)
    With JpgRec
        .AddNew
        .Fields("Num") = jpgNum  
        .Fields("User") = User  
        .Fields("Width") = jpgWidth  
        .Fields("Height") = jpgHeight  
        .Update
    End With
End Sub

Private Function GetJpgInfo(ByRef Path)
    Dim File, c, s, jpgWidth, jpgHeight
    
    Set File = Fso.OpenTextFile(Path)
  
    GetJpgInfo = Array("", "")  
    
    If File.Read(2) = Chr(&HFF) & Chr(&HD8) Then
        Do While File.Read(1) = Chr(&HFF)
            c = Asc(File.Read(1))
            
            s = File.Read(Asc(File.Read(1)) * 256 + Asc(File.Read(1)) - 2)
            
            If c = &HC0 Or c = &HC2 Then
                jpgWidth = Asc(Mid(s, 4, 1)) * 256 + Asc(Mid(s, 5, 1))
                jpgHeight = Asc(Mid(s, 2, 1)) * 256 + Asc(Mid(s, 3, 1))
                GetJpgInfo = Array(jpgWidth, jpgHeight):  Exit Do
            End If
        Loop
    End If
    File.Close
End Function

Private Function GetVarText(ByRef Text, ByVal s1, ByVal s2, ByVal s3, ByVal s4)
    Dim Arg, i
    
    GetVarText = Text:  Arg = Array(0, s1, s2, s3, s4)
    
    For i = 1 To UBound(Arg)
        GetVarText = Replace(GetVarText, "$" & (i), Arg(i))  
    Next
End Function

    Set Shell = CreateObject("Shell.Application")  

Private Sub InitHtmFiles(ByRef User)
    Dim File, Path, Text, Jpg, JpgNum, jpgWidth, jpgHeight
    
    On Error Resume Next
    
    Fso.DeleteFile (P1 & User & "\*.htm")  
    
    On Error GoTo 0
    
    Set File = Fso.OpenTextFile(P0 & HtmPages):  Text = File.ReadAll:  File.Close
    
    Call OpenJpgRec
    
    Path = P3 & User
    
    For Each Jpg In Shell.Namespace(Path).Items
        If LCase(Right(Jpg.Name, 4)) = ".jpg" Then  
            JpgNum = Fso.GetBaseName(Jpg.Name)
            jpgWidth = Split(Shell.Namespace(Path).GetDetailsOf(Jpg, 27))(0)
            jpgHeight = Split(Shell.Namespace(Path).GetDetailsOf(Jpg, 28))(0)
            Call WriteJpgRec(JpgNum, User, jpgWidth, jpgHeight)
            Call CreatePagesFile(JpgNum, User, Text)
        End If
    Next
    
    If User = Name1 Then
        Call CreateControlFile(P0 & HtmLeft)
    ElseIf User = Name2 Then
        Call CreateControlFile(P0 & HtmRight)
    End If
End Sub