'*** v8.8 *** www.dieseyer.de ******************************* ' ' Datei: Suchmaschine.vbs ' Autor: W.Schmelz ' Auf: www.dieseyer.de ' 'In der Datei "GrdProbl.txt" wird gleich ein eingegebener 'Begriff gesucht - oder 2 durch Komma getrennte, eingebene 'Worte. Bei nur einer Fundstelle wird der Inhalt des ein- 'zigen gefundenen Abschnitt in einer Hilfs-Datei angezeigt, 'die gelöscht wird! Bei mehreren Fundstellen werden diese 'zunächst alle genannt. Es ist dann möglich, die erste ge- 'fundene auszugeben, eine ausgesuchte oder alle hinterein- 'ander weg gesetzt! Von allen weiteren Fundstellen werden 'am Ende die Namen genannt! ' 'Bei mehr als 10 Funden wird die erste Fundstelle gezeigt! ' 'Die Fundstellen werden mit 11111 bzw. 22222 markiert ! '*********************************************************** 'CopyRight W. Schmelz, 19.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 Ende, Zahl, Zahl1, Zahl2, Hier, Hier1, Hier2, Word, Nr() Dim Fund, Start1(), Start2(), Zeile(), Datei, Beginn, Letzte Dim Zwei, Titel, UV, Schluss, ZahlR, Ask, NochNr(), Rest Dim Neu, Stelle Titel=" Begriffe in GrdProbl.txt suchen" Datei="GrdProbl.txt" UV=VbCR&VbCR 'Namen des Startordner suchen: '***************************** AktVerz=Fso.GetParentFolderName(WScript.ScriptFullName) 'Prüfen, ob "GrdProbl.txt" im Ordner enthalten: '********************************************** If not Fso.FileExists(AktVerz&"\GrdProbl.txt") then _ MsgBox UV&VbCR&"Im Ordner "&_ "ist ""GrdProbl.txt"" nicht enthalten ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Die Abfrage der zu suchenden Begriffe - oder ein Abbruch: '********************************************************* Word=InputBox(UV&_ " Geben Sie den zu suchenden Begriff ein !"&UV&_ " Große und kleine Buchstaben sind egal !"&UV&_ " GrdProbl.txt wird auf den Begriff abgesucht!"&UV&_ " Der erste gefundene Abschnitt wird ange-"&UV&_ " zeigt, die Nummern der weiteren genannt !"&UV&_ " Erste Fundstelle, bestimmte, alle einsehbar !"&UV&_ " Die Fundzeilen sind mit Zeichen markiert !"&UV&_ " Sogar zwei Worte mit "" , "" sind möglich !!"&_ UV,Titel,"Run,Notepad") Word=LCase(Word) If Word="" then WScript.Quit 'Die evtl. eingetragenen Leerstellen beseitigen, 'denn sie könnten bei der Suche Probleme geben ! '*********************************************** Neu="" For i=1 to Len(Word) Stelle=Mid(Word,i,1) If not Stelle=" " then Neu=Neu&Stelle Next Word=Neu 'Die evtl. eingetragenen Leerstellen beseitigen, 'denn sie könnten bei der Suche Probleme geben ! '*********************************************** 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 zuviele Worte eingetragen wurden: '******************************************** N1="0" '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 vorkommt: '****************************************** If N1>1 then MsgBox UV&VbCR&"In der Eingabe "&_ "sind zuviele Kommata ! "&UV&_ VbCR,VbCritical,Titel:WScript.Quit 'Abbruch !! 'Eine oder zwei Eingaben? '************************ 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,",") 'Abbruch, wenn Wort(1)="" oder nur 1 Buchstabe 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 Datei "GrdProbl.txt" öffnen und lesen: '****************************************** Set File=Fso.OpenTextFile(Datei,1,true) i=1 Do until File.AtEndOfStream ReDim Preserve Zeile(i) Zeile(i)=File.ReadLine i=i+1 Loop Ende=i-1 File.Close Set File=Nothing '*********************************************** 'Inhaltsverzeichnis ist nicht mit zu betrachten, 'Zeile(i) erst ab "############ . . . " rechnen: '*********************************************** i=1 Do until i>Ende If Left(Zeile(i),3)="###" then Beginn=i i=i+1 Loop 'Erst mit "Beginn" wird die Zeilenbetrachtung gestartet! s.u. 'Schlusszeichen der Zeilen bis dahin ermitteln: '********************************************** ReDim Preserve Nr(Ende) k=1 Do until k>Beginn Nr(k)=Right(Zeile(k),1) k=k+1 Loop 'Die größte Abschnittnummer des Inhaltsverzeichnis ermitteln: '************************************************************ Schluss="1" 'Größte Abschnittnummer! x=1 Do until x>Beginn If (Asc(Nr(x))>47 and Asc(Nr(x))<58) then 'nur Zahlen nehmen If Right(Zeile(x),3)>=Schluss then Schluss=Right(Zeile(x),3) End If x=x+1 Loop 'Die Zeilen jetzt ab " Beginn " neu nummerieren: '*********************************************** k=1 Do until k>Ende-Beginn Zeile(k)=Zeile(Beginn+k) k=k+1 Loop 'Die Suche des Begriffes 1 in den neu benannten Zeilen: '****************************************************** Hier1="" Zahl1="0" 'Zahl der Fundstellen For i=1 to Ende k=1 Do until k>Len(Zeile(i))-Len(Wort(0))+1 If LCase(Mid(Zeile(i),k,Len(Wort(0))))=Wort(0) then If Len(Hier1)>0 then Hier1=Hier1&"|"&i If Hier1="" then Hier1=i Zahl1=Zahl1+1 'Wie oft "Wort(0)" gefunden ? End If k=k+1 Loop Next 'Der 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,"|") 'Die Fundstellen für Wort1 werden markiert: '****************************************** i=0 Do until i=Zahl1 'Wenn noch nicht markiert: If not Right(Zeile(Ort1(i)),5)="11111" then Zeile(Ort1(i))=Zeile(Ort1(i))&" 1111111111" End If i=i+1 Loop 'Die Startzeile der Abschnitte suchen: '************************************* ReDim Preserve Start1(Zahl1+1) a=0 Do until a=Zahl1 Start1(a)=Ort1(a) 'Anfang setzen und rückwärts gehen k=1 Do until (Zeile(Start1(a))="" and Zeile(Start1(a)-1)="" and _ Zeile(Start1(a)-2)="" and Zeile(Start1(a)-3)="") Start1(a)=Ort1(a)-k k=k+1 Loop Start1(a)=Start1(a)+1 a=a+1 Loop 'Die Nummern der Abschnitte ermitteln: '************************************* b=1 Do until b=Zahl1 Ort1(b)=Left(Zeile(Start1(b)),3) b=b+1 Loop Fund=Left(Zeile(Start1(0)),3) 'Nr. des 1. Fundortes Ort1(0)=Left(Zeile(Start1(0)),3) 'Zeile von diesem '****************************************************** '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 'Namen des Startordner suchen, Ausgabedatei benennen: '**************************************************** Stamm=Fso.GetParentFolderName(Datei) DateiN=Fso.GetBaseName(Datei)&"-Such.txt" AktVerz=Replace(Datei,Fso.GetFileName(Datei),"") Datei=AktVerz&DateiN 'Gefundene Abschnitts-Nr. auflisten: '*********************************** Rest=Fund k=1 Do until k=Zahl1 If (Ort1(k)<>Fund and Letzte<>Ort1(k)) then Rest=Rest&"|"&Ort1(k) Letzte=Ort1(k) End If If Ort1(k)=Schluss then k=Zahl1-1 'Abbruch am letzten Abschnitt k=k+1 Loop 'Falls mehr als eine Fundstelle da ist: '************************************** If Len(Rest)>3 then '<<<<<<<<<<<<<<<<<< Rest=Right(Rest,Len(Rest)-4) '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 'Die weiteren, gefundenen Abschnitte aufsplitten, Noch(0) usw.: '************************************************************** Noch=Split(Rest,"|") 'Deren Überschriften auflisten in Txt: '************************************* For i=1 to Ende For k=1 to ZahlR ReDim Preserve NochNr(k) If Left(Zeile(i),3)=Noch(k-1) then NochNr(k)=i If (Right(Zeile(NochNr(k)),23)="1111111111 2222222222" or _ Right(Zeile(NochNr(k)),23)="2222222222 1111111111") then Txt=Txt&VbCR&k+1&") "&Left(Zeile(NochNr(k)),Len(Zeile(NochNr(k)))-23) ElseIf (Right(Zeile(NochNr(k)),5)="11111" or _ Right(Zeile(NochNr(k)),5)="22222") then Txt=Txt&VbCR&k+1&") "&Left(Zeile(NochNr(k)),Len(Zeile(NochNr(k)))-13) Else Txt=Txt&VbCR&k+1&") "&Zeile(NochNr(k)) End If End If Next Next '***************************************************************** ' Für mehr als einen, aber bis 10 Fundstellen, die Möglichkeit er- ' öffnen, alle Abschnitte einzeln anzuzeigen - oder nur bestimmten '***************************************************************** If ZahlR<=9 then 'Zahl der zusätzlichen Fundstellen 'Ihre Liste bilden: '****************** If (Right(Zeile(Start1(0)),23)="1111111111 2222222222" or _ Right(Zeile(Start1(0)),23)="2222222222 1111111111") then Txt1=Left(Zeile(Start1(0)),Len(Zeile(Start1(0)))-23) ElseIf (Right(Zeile(Start1(0)),5)="11111" or _ Right(Zeile(Start1(0)),5)="22222") then Txt1=Left(Zeile(Start1(0)),Len(Zeile(Start1(0)))-13) Else Txt1=Zeile(Start1(0)) End If 'Nachfrage, was als Ausgabe gewünscht wird: '****************************************** Ask=InputBox(VbCR&_ " Das Programm hat außer dem 1. Abschnitt:"&UV&_ Txt1&UV&_ " noch die folgenden Abschnitte gefunden :"&VbCR&_ Txt&UV&_ " Bei "" a "" wird obiger erster Abschnitt ange-"&VbCR&_ " zeigt, die weiteren Nummern nur genannt !"&VbCR&_ " Bei "" b "" werden sämtliche Abschnitte 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 If ZahlR>=10 then Ask="a" 'Bei zuviel Fundstellen nur erste ausgeben! End If '<<<<<<<<<<<<<<<<<< 'Startzeile Start1(i) weiterer - nicht doppelter - Abschnitte suchen: '******************************************************************** For i=1 to ZahlR ReDim Preserve Start1(i) For k=1 to Ende If Left(Zeile(k),3)=Noch(i-1) then Start1(i)=k Next Next '#################################################### 'Ausgabedatei öffnen, gefundene Abschnitte schreiben: '#################################################### Set File=Fso.OpenTextFile(Datei,2,true) If (Ask="a" and ZahlR>=1) then File.WriteLine(" ") File.WriteLine(" ") If Zwei="0" then File.Write("Der Begriff "" "&Wort(0)) File.WriteLine(" "" steht erstmalig in folgendem Abschnitt:") File.Write("********************************") File.WriteLine("*********************************") End If If Zwei="1" then File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1)) File.WriteLine(" "" stehen erstmalig in folgendem Abschnitt:") File.Write("******************************************") File.WriteLine("***************************************") End If End If If Ask="" then File.WriteLine(" ") File.WriteLine(" ") If Zwei="0" then File.Write("Der Begriff "" "&Wort(0)) File.WriteLine(" "" steht nur in folgendem Abschnitt:") File.Write("*****************************") File.WriteLine("****************************") End If If Zwei="1" then File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1)) File.WriteLine(" "" stehen nur in folgendem Abschnitt:") File.Write("*************************************") File.WriteLine("************************************") End If End If File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") 'Erste Fundstelle ausgeben: '************************** If (Ask="a" or Ask="") then i=Start1(0) Do until (Zeile(i)="" and Zeile(i+1)="" and _ Zeile(i+2)="" and Zeile(i+3)="") File.WriteLine(Zeile(i)) i=i+1 Loop End If 'Alle Fundstellen ausgeben: '************************** If Ask="b" then For k=0 to ZahlR i=Start1(k) Do until (Zeile(i)="" and Zeile(i+1)="" and _ Zeile(i+2)="" and Zeile(i+3)="") File.WriteLine(Zeile(i)) i=i+1 Loop File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") File.WriteLine(" ") Next End If 'Gewünschte Fundstelle ausgeben: '******************************* If not (Ask="a" or Ask="b" or Ask="") then i=Start1(Ask-1) 'Nr. beginnen erst mit 2 ! Do until (Zeile(i)="" and Zeile(i+1)="" and _ Zeile(i+2)="" and Zeile(i+3)="") File.WriteLine(Zeile(i)) i=i+1 Loop End If File.WriteLine(" ") File.WriteLine(" ") 'Bei Anzeige einer Fundstelle die weiteren 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 'Weitere 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(" "" steht in folgenden Abschnitten:") File.Write("****************************") File.WriteLine("********************************") File.WriteLine(" ") End If If Zwei="1" then File.Write("Die Begriffe "" "&Wort(0)&" "" und "" "&Wort(1)) File.WriteLine(" "" stehen in folgenden Abschnitten:") File.Write("*************************************") File.WriteLine("************************************") File.WriteLine(" ") End If k=0 Do until k=Zahl1 If Letzte<>Ort1(k) then File.Write(" "&Ort1(k)) Letzte=Ort1(k) Reihe=1+Reihe If Reihe mod 13="0" then File.WriteLine(" ") 'Reihen begrenzen! End If If Ort1(k)=Schluss then k=Zahl1-1 'Abbruch am letzten Abschnitt k=k+1 Loop End If End If 'Folgendes muss sein, damit die Datei am Schluss löschbar wird: '************************************************************** File.Close Set File=Nothing 'Bei Erfolg den Abschnitt mit dem Begriff anzeigen: '************************************************** Wss.Run "Notepad """&Datei&""" " WScript.Sleep 2000 'Die Ausgabe-Datei löschen: '************************** Fso.DeleteFile Datei '############################################################# Sub Doppel 'Die Suche des Begriff2 (Wort(1)) in den neu benannten Zeilen: '************************************************************* Hier2="" Zahl2="0" 'Zahl der Fundstellen For i=1 to Ende k=1 Do until k>Len(Zeile(i))-Len(Wort(1))+1 If LCase(Mid(Zeile(i),k,Len(Wort(1))))=Wort(1) then If Len(Hier2)>0 then Hier2=Hier2&"|"&i If Hier2="" then Hier2=i Zahl2=Zahl2+1 'Wie oft "Wort(1)" gefunden ? End If k=k+1 Loop 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 Ort1(0) usw.: '********************************************** Ort2=Split(Hier2,"|") 'Die Fundstellen für Wort2 werden markiert: '****************************************** i=0 Do until i=Zahl2 'Wenn noch nicht markiert: If not Right(Zeile(Ort2(i)),5)="22222" then Zeile(Ort2(i))=Zeile(Ort2(i))&" 2222222222" End If i=i+1 Loop 'Den Anfang der gefundenen Abschnitte suchen: '******************************************** ReDim Preserve Start2(Zahl2+1) a=0 Do until a=Zahl2 Start2(a)=Ort2(a) 'Anfang setzen und rückwärts gehen k=1 Do until (Zeile(Start2(a))="" and Zeile(Start2(a)-1)="" and _ Zeile(Start2(a)-2)="" and Zeile(Start2(a)-3)="") Start2(a)=Ort2(a)-k k=k+1 Loop Start2(a)=Start2(a)+1 a=a+1 Loop 'Die Nummern dieser Abschnitte ermitteln: '**************************************** b=0 Do until b=Zahl2 Ort2(b)=Left(Zeile(Start2(b)),3) b=b+1 Loop 'Gemeinsame Fundstellen beider 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 If Ort1(i)=Ort2(k) 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: '************************************ Zahl1="1" For i=1 to Len(Hier) If Mid(Hier,i,1)="|" then Zahl1=1+Zahl1 Next Fund=Ort1(0) 'Erster gemeinsamer Fundort 'Die Zeilennummer des ersten gemeinsamen Fundortes: '************************************************** For i=1 to Ende If Left(Zeile(i),3)=Fund then Start1(0)=i Next End Sub