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