http://dieseyer.de • all rights reserved • © 2011 v11.4
'*** 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
http://dieseyer.de • all rights reserved • © 2011 v11.4