'*** v8.8 *** www.dieseyer.de ****************************** ' ' Datei: VbsTxtDocSuchmaschine.vbs ' Autor: W.Schmelz ' Auf: www.dieseyer.de ' 'In den VBS-Dateien des Ordners wird gleich ein eingegebener 'Begriff gesucht - oder zwei durch Komma getrennte eingebene 'Begriffe. Bei nur einer Fundstelle wird der Inhalt der ein- 'zigen gefundenen Datei in einer Hilfs- Datei angezeigt, die 'sich selbst löscht! Bei mehreren Fundstellen werden diese 'zunächst alle genannt und es ist möglich, die erste gefund- 'ene Datei auszugeben, eine ausgesuchte oder alle hinterein- 'ander weg gesetzt! Von allen weiteren Fundstellen werden am 'Ende die Namen genannt! ' 'Auch andere Dateiarten wie "Txt" können durchsucht werden, 'sogar Doc-Dateien sind jetzt möglich geworden !! 'Wichtig ist: Nichts Aufwändiges nebenher laufen lassen !!! ' 'Die gefundenen Zeilen werden mit 11111 oder 22222 markiert! '*********************************************************** 'CopyRight W. Schmelz, 25.07.2008 'Die Objekte u. a. werden für das Programm bereit gestellt: '********************************************************** Set Wss=WScript.CreateObject("WScript.Shell") Set Fso=WScript.CreateObject("Scripting.FileSystemObject") Set Arg=Wscript.Arguments Dim Titel, AktVerz, Zwei, Word, Hier1, Zahl, ZahlR, DMax, N1 Dim Datei, Zeile(), Linie(), Numm(), Endg, Ende(), Zahl1, UV Dim Zahl2, DZahl, Hier2, Hier, Neu, Einzel, ZahlDoc, Linien() Titel=" Begriffe in VBS-Sammlung suchen" UV=VbCR&VbCR 'Den Namen des Startordner suchen, die Ausgabedatei benennen: '************************************************************ AktVerz=Fso.GetParentFolderName(WScript.ScriptFullName) DateiM=Fso.GetBaseName(WScript.ScriptFullName)&"-M.txt" DateiM=AktVerz&"\"&DateiM DateiS=Fso.GetBaseName(WScript.ScriptFullName)&"-S.txt" DateiS=AktVerz&"\"&DateiS 'Die Festlegung der zu untersuchenden Dateien - oder Abbruch: '************************************************************ Endg=InputBox(UV&UV&_ " Geben Sie ein, welche Dateien im Ordner"&UV&_ " auf die gleich fest zu legenden Begriffe"&UV&_ " durchsucht werden ! ""Vbs"", ""Txt"", ""Doc"""&UV&_ " sind prüfbar. Bei ""Doc"" sind unbedingt"&UV&_ " Scanner und Aufwändiges zu schließen!"&UV&_ " Zur Sicherheit besser immer so halten!"&_ UV&UV,Titel,"vbs") Endg=LCase(Endg) If Endg="" then WScript.Quit 'Die Abfrage der zu suchenden Begriffe - oder doch ein Abbruch: '************************************************************** Word=InputBox(UV&UV&_ " Geben Sie den zu suchenden Begriff ein !"&UV&_ " Große und kleine Buchstaben sind egal !"&UV&_ " In allen Dateien wird der Begriff gesucht!"&UV&_ " Alle gefundenen Dateien werden genannt !"&UV&_ " Erste Datei, bestimmte, alle sind einsehbar !"&UV&_ " Die Fundzeilen sind mit Zeichen markiert !"&UV&_ " Sogar zwei Worte mit "" , "" sind möglich !!"&_ UV&UV,Titel,"winmg,process") Word=LCase(Word) If Word="" then WScript.Quit 'Die evtl. eingetragenen Leerstellen beseitigen, 'denn sie könnten Probleme bei der Suche ergeben ! '************************************************* Neu="" For i=1 to Len(Word) Stelle=Mid(Word,i,1) If not Stelle=" " then Neu=Neu&Stelle Next Word=Neu 'Prüfen, ob mehr als zwei Worte eingetragen worden sind: '******************************************************* N1="0" 'Dafür die Zahl der Kommata prüfen For i=1 to Len(Word) If Mid(Word,i,1)="," then N1=1+N1 Next 'Abbruch, wenn mehr als ein Komma bzw. 2 Worte vorkommen: '********************************************************* If N1>1 then MsgBox UV&VbCR&"In der Eingabe "&_ "sind zuviele Kommata ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Wurden eine oder zwei Eingaben in "Word" aufgefunden? '***************************************************** Zwei="0" For i=1 to Len(Word) If Mid(Word,i,1)="," then Zwei="1" Next 'Die Eingabe ggf. aufsplitten in Wort(0) und Wort(1): '****************************************************** Wort=Split(Word,",") 'Der Abbruch, wenn Wort(1)= "" oder nur 1 Buchstaben hat: '******************************************************** If Zwei="1" then If (Wort(1)="" or Len(Wort(1))=1) then MsgBox UV&VbCR&_ "Das zweite Wort "&_ "war leer oder sinnlos ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! End If 'Die "Endg" - Dateien in "AktVerz" zählen, durchbenennen: '******************************************************** Set Data=Fso.GetFolder(AktVerz).Files DZahl="0" i=1 For each File in Data ReDim Preserve Dat(i) If LCase(Fso.GetExtensionName(File))=Endg then Dat(i)=File DZahl=1+DZahl i=i+1 End If Next 'Prüfen, ob gewünschte Dateien im Ordner überhaupt da sind: '********************************************************** If DZahl="0" then MsgBox UV&VbCR&"In diesem Ordner "&_ "ist keine "" "&Endg&" "" - Datei ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Falls jetzt Word-Dateien untersucht werden sollen: '************************************************** If Endg="doc" then If not Fso.FolderExists(AktVerz&"\DocDoc") then _ Set Ordn=Fso.CreateFolder (AktVerz&"\DocDoc") WordDoc End If 'Die Länge Ende(i) aller Dat(i) ermitteln: '***************************************** i=1 Do until i>DZahl ReDim Preserve Ende(i) 'Länge von Dat(i) Set File=Fso.OpenTextFile(Dat(i),1,true) 'Dat(i) öffnen 'Dafür die Zeilen von Dat(i) auslesen: '************************************* k=1 Do until File.AtEndOfStream ReDim Preserve Linie(k) Linie(k)=File.ReadLine k=k+1 Loop Ende(i)=k-1 'Länge von Dat(i) File.Close Set File=Nothing i=i+1 Loop 'Die größte aller der vorkommenden Dateilängen ermitteln: '********************************************************* DMax="1" For a=1 to DZahl If Ende(a)>Int(DMax) then DMax=Ende(a) Next 'Alle "Endg"-Dateien öffnen, alle Zeilen nummeriert lesen: '********************************************************* 'In Zeile(i,k) ist das i die Datei-Nr. und k die Zeilen-Nr ReDim Preserve Zeile(DZahl,DMax) 'Darf nur 1x definiert 'werden, daher auf einmal festlegen, mit DMax ! i=1 Do until i>DZahl Set File=Fso.OpenTextFile(Dat(i),1,true) 'Dat(i) öffnen 'Zeilen(i,k) in Dat(i) festlegen k=1 Do until k>Ende(i) Zeile(i,k)=File.ReadLine k=k+1 Loop File.Close Set File=Nothing i=i+1 Loop 'Die Suche des Begriffes 1 in allen den Zeilen(i,k): '**************************************************** Hier1="" Zahl1="0" 'Zahl der Fundstellen For i=1 to DZahl For k=1 to Ende(i) l=1 Do until l>Len(Zeile(i,k))-Len(Wort(0))+1 If LCase(Mid(Zeile(i,k),l,Len(Wort(0))))=Wort(0) then If Len(Hier1)>0 then Hier1=Hier1&"|"&i&","&k If Hier1="" then Hier1=i&","&k Zahl1=Zahl1+1 'Wie oft "Wort(0)" gefunden ? End If l=l+1 Loop Next Next 'Ein Abbruch - falls nichts zu finden war: '***************************************** If Hier1="" then MsgBox UV&VbCR&"Der Begriff "" "&_ Wort(0)&" "" ist nicht zu finden ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Die Aufsplittung der Fundorte in Ort1(i), erster ist Ort1(0): '************************************************************* Ort1=Split(Hier1,"|") Fund=Ort1(0) 'Die Fundstellen für Wort 1 werden am Zeilenende markiert: '********************************************************* i=0 Do until i=Zahl1 Nr=Split(Ort1(i),",") 'Ort1(i) in 2 Zahlen splitten 'Wenn noch nicht markiert: If not Right(Zeile(Nr(0),Nr(1)),5)="11111" then Zeile(Nr(0),Nr(1))=Zeile(Nr(0),Nr(1))&" 1111111111" End If i=i+1 Loop '******************************************************* 'Bei zwei Begriffen die gemeinsamen Fundorte ermitteln ! 'Am Ende wird so bezeichnet wie bei nur einem Begriff, 'damit die Ausgabe so erfolgt wie bei einem Begriff !!! '******************************************************* If Zwei="1" then Doppel 'Sub - Programm aufrufen '" Txt " - Hilfsdateien und Ordner " DocDoc " wieder löschen: '************************************************************ If LCase(Endg)="doc" then For i=1 to DZahl If Fso.FileExists (Dat(i)) then _ Fso.DeleteFile Dat(i) Next WScript.Sleep 500 If Fso.FolderExists (AktVerz&"\DocDoc") then _ Fso.DeleteFolder AktVerz&"\DocDoc" End If 'Die gefundenen Datei-Nrn. (auf keinen Fall doppelt) auflisten: '************************************************************** Rest=Fund k=1 Do until k=Zahl1 Nr1=Split(Ort1(k),",") 'Ort1(k) in 2 Zahlen splitten Nr0=Split(Ort1(k-1),",") 'Ort1 davor auch! If (Ort1(k)<>Fund and Nr1(0)<>Nr0(0)) then Rest=Rest&"|"&Ort1(k) End If k=k+1 Loop 'Wieviele Fundstellen sind da? '***************************** Test=InStr(Rest,"|") 'Wann "Fund" zu Ende ? 'Bei nur einem Fund diesen dann melden: '************************************** ReDim Preserve Numm(1) If Test=0 then Ask="a" 'Ersten und einzigen Fundort melden Einzel="1" Numm(1)=Left(Fund,1) End If 'Falls mehrere Fundstellen zu beiden Begriffen zu finden waren: '************************************************************** If Test>0 then ' "End If" s.u. <<<<<<<<<<<<<<<<<< Rest=Right(Rest,Len(Rest)-Test) 'Restliche Fundorte ZahlR="1" 'Die Anzahl der restlichen Fundorte: For i=1 to Len(Rest) If Mid(Rest,i,1)="|" then ZahlR=1+ZahlR Next 'Der Name der ersten Fundstellen - Datei: '**************************************** ReDim Preserve Numm(1+ZahlR) Nr=Split(Fund,",") Numm(1)=Nr(0) Fund=Dat(Nr(0)) Txt1="1) "&Fso.GetFileName(Fund) 'Die weiteren, gefundenen Abschnitte aufsplitten, Noch(0) usw.: '************************************************************** Noch=Split(Rest,"|") 'Die restlichen Dateien auflisten in "Txt": '****************************************** For i=1 to ZahlR Nr=Split(Noch(i-1),",") Numm(i+1)=Nr(0) Txt=Txt&VbCR&i+1&") "&Fso.GetFileName(Dat(Nr(0))) If i=1 then Txt=i+1&") "&Fso.GetFileName(Dat(Nr(0))) Next 'Die gefundenen Dateien aufsplitten: '*********************************** Ergbn=Split(Txt,VbCR) 'Die größte Dateinamenlänge ermitteln: '************************************* NMax="1" For a=0 to ZahlR-1 If Len(Ergbn(a))>Int(NMax) then NMax=Len(Ergbn(a)) Next 'Die gefundenen Dateien mit Leerstellen auf gleiche Länge bringen: '***************************************************************** Lang=" " For i=1 to Int(NMax)+3 Lang=Lang&" " 'Gesamtlänge festlegen Next Txt2="" For i=0 to ZahlR-1 Txt2=Txt2&Ergbn(i)&Right(Lang,NMax+3-Len(Ergbn(i))) If i mod 3=2 then Txt2=Txt2&VbCRLF Next '**************************************************************** ' Für mehr als 10 Funddateien in einer Meldedatei alle gefundenen ' Dateien anzeigen und in einer Input - Box nach Weiterem fragen, ' denn in jeder Art Box ist nur begrenzter Platz zur Verfügung ! '**************************************************************** If ZahlR>=10 then 'Zahl der zusätzlichen Fundstellen 'Die Melde - Datei aller Fundorte schreiben: '******************************************* Set File=Fso.OpenTextFile(DateiM,2,true) File.WriteLine(" ") File.Write("Außer der ersten Datei "&Txt1) File.WriteLine(" wurden folgende Dateien gefunden !") File.WriteLine(" ") File.WriteLine(Txt2) File.Close Set File=Nothing 'Alle gefundenen Dateien in Txt - Datei mit Anweisungen anzeigen: '**************************************************************** Wss.Run "Notepad """&DateiM&""" " WScript.Sleep 2000 'Die Nachfrage, was als Ausgabe gewünscht wird: '********************************************** Ask=InputBox(UV&VbCR&_ " Bei "" a "" wird die obige erste Datei ange -"&VbCR&_ " zeigt, die weiteren Dateien nur genannt !"&VbCR&_ " Bei "" b "" werden sämtliche Dateien ein -"&VbCR&_ " zeln und aufeinander folgend angezeigt !"&VbCR&_ " Oder geben Sie die gewünschte Nr. ein !"&UV&_ VbCR,Titel,"a") Word=LCase(Word) If Ask="" then WScript.Quit End If '**************************************************************** ' Für 1 bis 10 Funddateien diese anzeigen und die Möglichkeit er- ' öffnen, alle Dateien zusammen anzuzeigen - oder nur bestimmte ! '**************************************************************** If ZahlR<=9 then 'Zahl der zusätzlichen Fundstellen 'Die Nachfrage, was als Ausgabe gewünscht wird: '********************************************** Ask=InputBox(VbCR&_ " Das Programm hat außer dieser 1. Datei :"&UV&_ Txt1&UV&_ " noch diese folgenden Dateien gefunden :"&VbCR&_ Txt&UV&_ " Bei "" a "" wird die obige erste Datei ange -"&VbCR&_ " zeigt, die weiteren Dateien nur genannt !"&VbCR&_ " Bei "" b "" werden sämtliche Dateien ein -"&VbCR&_ " zeln und aufeinander folgend angezeigt !"&VbCR&_ " Oder geben Sie die gewünschte Nr. ein !"&_ VbCR,Titel,"a") Word=LCase(Word) If Ask="" then WScript.Quit End If End If ' "If" s.o. <<<<<<<<<<<<<<<<<< '################################################################ 'Die Ausgabedatei öffnen und die gefundenen Dateien ausschreiben: '################################################################ Set File=Fso.OpenTextFile(DateiS,2,true) File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") 'Die erste Fundstelle ausgeben: '****************************** If (Ask="a" or Ask="1") then 'Fundstelle benennen: If Einzel<>"1" then File.Write("Die erste gefundene Datei heißt") If Einzel="1" then File.Write("Einzige gefundene Datei ist") File.WriteLine(" : "" "&Dat(Numm(1))&" "" ") File.Write("####################################") File.WriteLine("###################################") File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") i=1 Do until i=Ende(Numm(1))+1 File.WriteLine(Zeile(Numm(1),i)) i=i+1 Loop End If 'Sämtliche Fundstellen ausgeben: '******************************* If Ask="b" then For k=1 to 1+ZahlR 'Fundstellen benennen: File.Write("Die "&k&". te gefundene Datei heißt : "" ") File.WriteLine(Dat(Numm(k))&" "" ") File.Write("##################################") File.WriteLine("#####################################") File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") i=1 Do until i>Ende(Numm(k)) File.WriteLine(Zeile(Numm(k),i)) i=i+1 Loop File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") Next End If 'Eine gewünschte Fundstelle wird ausgegeben: '******************************************* If not (Ask="a" or Ask="b") then 'Gewünschte Fundstelle benennen: File.Write("Die "&Ask&". te gefundene Datei heißt : "" ") File.WriteLine(Dat(Numm(Ask))&" "" ") File.Write("##################################") File.WriteLine("#####################################") File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") i=1 Do until i>Ende(Numm(Ask)) File.WriteLine(Zeile(Numm(Ask),i)) i=i+1 Loop End If File.WriteLine(" ") File.WriteLine(" ") 'Bei der Anzeige einzelner Fundstellen weitere am Ende angeben: '************************************************************** If not Ask="b" then 'Wenn keine weiteren Fundstellen da sind: '**************************************** If Ort1(0)=Ort1(Zahl1-1) then File.WriteLine(" ") File.WriteLine(" ") File.WriteLine("Weitere Fundstellen sind nicht vorhanden !") File.WriteLine("******************************************") End If 'Die weiteren Fundstellen, dabei keine doppelt verwenden: '******************************************************** If not Ort1(0)=Ort1(Zahl1-1) then File.WriteLine(" ") File.WriteLine(" ") If Zwei="0" then File.Write("Der Begriff "" "&Wort(0)) File.WriteLine(" "" findet sich in folgenden Dateien:") File.Write("********************************") File.WriteLine("***************************") File.WriteLine(" ") End If If Zwei="1" then File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1)) File.WriteLine(" "" stehen beide in folgenden Dateien:") File.Write("*************************************") File.WriteLine("*************************************") File.WriteLine(" ") End If End If End If If Ask="b" then File.WriteLine("Das waren folgende Dateien:") File.WriteLine("***************************") End If 'Alle Fundstellen werden zum Schluss aufgezählt: '*********************************************** For i=1 to ZahlR+1 File.WriteLine(Dat(Numm(i))) Next 'Folgendes muss sein, damit die Datei am Schluss löschbar wird: '************************************************************** File.Close Set File=Nothing 'Die Meldedatei schließen, falls sie noch geöffnet sein sollte: '************************************************************** If Fso.FileExists(DateiM) then Set Wmi=GetObject("Winmgmts:") Set System=Wmi.InstancesOf("Win32_Process") For each Process in System If LCase(Process.name)=LCase("Notepad.exe") then Process.Terminate (0) End if Next End If 'Bei Erfolg den Abschnitt mit dem Begriff - oder allen anzeigen: '*************************************************************** Wss.Run "Notepad """&DateiS&""" " WScript.Sleep 2000 'Die Melde - und die Ausgabe -Datei löschen: '******************************************* If Fso.FileExists(DateiM) then Fso.DeleteFile DateiM If Fso.FileExists(DateiS) then Fso.DeleteFile DateiS '############################################################ Sub Doppel 'Die Suche des Begriff 2 (Wort(1)) in sämtlichen Zeilen(i,k): '************************************************************ Hier2="" Zahl2="0" 'Zahl der Fundstellen For i=1 to DZahl For k=1 to Ende(i) l=1 Do until l>Len(Zeile(i,k))-Len(Wort(1))+1 If LCase(Mid(Zeile(i,k),l,Len(Wort(1))))=Wort(1) then If Len(Hier2)>0 then Hier2=Hier2&"|"&i&","&k If Hier2="" then Hier2=i&","&k Zahl2=Zahl2+1 'Wie oft "Wort(1)" gefunden? End If l=l+1 Loop Next Next 'Oder Abbruch - falls Begriff 2 nicht gefunden wurde: '**************************************************** If Hier2="" then MsgBox UV&VbCR&"Der Begriff "" "&_ Wort(1)&" "" ist nicht zu finden ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Die Aufsplittung der Fundorte in Ort2(0) usw.: '********************************************** Ort2=Split(Hier2,"|") Fund=Ort2(0) '1. Fundstelle mit Wort 2 'Die Fundstellen für Wort2 werden markiert: '****************************************** i=0 Do until i=Zahl2 Nr=Split(Ort2(i),",") 'Ort2(i) in 2 Zahlen splitten 'Wenn noch nicht markiert: If not Right(Zeile(Nr(0),Nr(1)),5)="22222" then Zeile(Nr(0),Nr(1))=Zeile(Nr(0),Nr(1))&" 2222222222" End If i=i+1 Loop 'Gefundene Datei-Nrn. (auf keinen Fall doppelte) auflisten: '********************************************************** Rest=Fund k=1 Do until k=Zahl2 Nr1=Split(Ort2(k),",") 'Ort2(k) in 2 Zahlen splitten Nr0=Split(Ort2(k-1),",") 'Ort2 davor auch! If (Ort2(k)<>Fund and Nr1(0)<>Nr0(0)) then Rest=Rest&"|"&Ort2(k) End If k=k+1 Loop 'Falls mehr als eine Fundstelle da ist: '************************************** Test=InStr(Rest,"|") 'Wann "Fund" zu Ende ? If Test>0 then ' <<<<<<<<<<<<<<<<<< Rest=Right(Rest,Len(Rest)-Test) 'Restliche Fundorte ZahlR="1" 'Die Anzahl der restlichen Fundorte: For i=1 to Len(Rest) If Mid(Rest,i,1)="|" then ZahlR=1+ZahlR Next End If 'Name der ersten Fund - Datei: '***************************** ReDim Preserve Numm(1+ZahlR) Nr=Split(Fund,",") Numm(1)=Nr(0) Fund=Dat(Nr(0)) '1. Datei ! 'Die gemeinsamen Fundstellen für beide Begriffe suchen: '****************************************************** If Zahl1>=Zahl2 then Zahl=Zahl1 If Zahl2>=Zahl1 then Zahl=Zahl2 Hier="" i=0 Do until i=Zahl1 k=0 Do until k=Zahl2 Nr1=Split(Ort1(i),",") Nr2=Split(Ort2(k),",") If Nr1(0)=Nr2(0) then If Hier="" then Hier=Ort1(i) If Hier<>"" then Hier=Hier&"|"&Ort1(i) End If k=k+1 Loop i=i+1 Loop '########################################################### 'Ab hier wird alles so bezeichnet wie bei nur einem Begriff, 'damit die Ausgabe genau so erfolgt wie bei einem Begriff !! '########################################################### 'Die Aufsplittung der gemeinsamen Fundorte in Ort1(0) usw.: '*********************************************************** Ort1=Split(Hier,"|") 'Abbruch, falls die beiden Begriffe nicht gemeinsam auftreten: '************************************************************* If Hier="" then MsgBox UV&VbCR&"Die Begriffe "" "&Wort(0)&_ " "" und "" "&Wort(1)&" "" "&_ " treten nicht gemeinsam auf ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Die Anzahl der gemeinsamen Fundorte bestimmen: '********************************************** Zahl1="1" For i=1 to Len(Hier) If Mid(Hier,i,1)="|" then Zahl1=1+Zahl1 Next Fund=Ort1(0) 'Erster gemeinsamer Fundort End Sub '############################################################# Sub WordDoc 'Den aktuellen Ordner auf "Doc" - Dateien durchsuchen: '***************************************************** Set Data=Fso.GetFolder(AktVerz).Files ZahlDoc="0" i=1 For each File in Data ReDim Preserve Dat(i) If LCase(Fso.GetExtensionName(File))=Endg then Dat(i)=File ZahlDoc=1+ZahlDoc 'Zahl der Doc-Dateien i=i+1 End If Next 'Die "Doc" - Dateien als "Txt" - Hilfs-Dateien neu speichern: '************************************************************ For x=1 to ZahlDoc 'Zu Doc-Datei die Txt-Datei mit gleichem Namen festlegen: Namen=Left(Fso.GetFileName(Dat(x)), _ Len(Fso.GetFileName(Dat(x)))-3)&"txt" If x="1" then Const WdFormatText=2 Set WinWord=CreateObject("Word.Application") With WinWord .Documents.Open(Dat(x)) .ActiveDocument.SaveAs AktVerz&"\DocDoc\"&Namen,WdFormatText .Quit End With '"Dat(x) als Txt-Datei aus "DocDoc" definieren: Dat(x)=AktVerz&"\DocDoc\"&Namen Next End Sub