[VBS] Moteur de recherche en Vbscript

**hackoofr** · 03/01/2014, 15h17

Suite à cette discussion ==> Fonction recherche contenu de windows on a parvenu à ce script : Moteur de recherche en Vbscript : C'est Vbscript qui scanne les fichiers de type "fichiers texte (".txt",".htm",".asp",".php",".rtf",".html",".htm",".hta",".xml",".csv",".vbs" etc...), et de les ouvrir les uns après les autres pour en extraire la portion du texte contenant le mot recherché.
Cependant il y a un petit problème pour les fichiers de type Excel (.xls,.xlsx)
Alors, je viens vers vous pour m'apporter une petite solution à ce problème.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
'**********************************************************************************
'Description du script VBS : Rechercher dans le contenu des fichiers de type texte
'**********************************************************************************
'En balayant les fichiers de type "fichiers texte" (fichiers ".txt",".htm",".asp",".php",".rtf",".html",".htm",".hta",".xml",".doc",".docx",".csv",".vbs" etc...),
'de les ouvrir les uns après les autres pour en extraire la portion de texte contenant le mot recherché.
'Le petit moteur peut toutefois rendre service pour explorer (en local) de petits sites Intranet (sans indexation préalable des pages).
'Code Original ==> http://jacxl.free.fr/cours_xl/vbs/moteur_rech.vbs
'***************************************************************************************************************************************************************
'Description de la mise à jour par Hackoo en 19/12/2013
'- Ajout d'une fonction pour parcourir le dossier à traiter par la fonction BrowseForFolder afin de rendre le script plus convivial et facile à manipuler
'- le résultat de la recherche est dans un fichier de type HTA au lieu dans un fichier de type HTML crée dans le dossier temporaire
'- Ajout de la fonction Explore() intégré dans le HTA pour explorer chaque fichier à part dans l'explorateur Windows
'- Ajout de la fonction HtmlEscape()
'***************************************************************************************************************************************************************
'On Error Resume Next
dim tabl()
dim tablold()
redim tabl(1)
tabl(0)="jetpack"
num=1
nbtot=0
nboct=0
nbssrep=0
Titre = "Recherche dans le contenu des fichiers de type texte"
Set fs = CreateObject("Scripting.FileSystemObject")
'choix du répertoire
nomrep = Parcourir_Dossier()
'choix du mot recherché
mot_cherch=inputbox("mot recherché ?",Titre,"43,22")
 
'traiter le cas où nomrep est un disque ou un nom non valide
if not fs.folderexists(nomrep) or ucase(fs.getdrivename(nomrep))=ucase(replace(nomrep,"\","")) then
    MsgBox "nom de répertoire non valide"
    wscript.quit
end if
tabl(1)=nomrep
 
'créer le fichier texte et l'ouvrir en appending
Dim tempFolder : Set tempFolder = fs.GetSpecialFolder(2)
Dim tempfile : tempFile = tempFolder & "\liste_fichiers.hta"
'msgbox tempFile
fichresult = tempFile 
Set nouv_fich = fs.OpenTextFile(fichresult,2,true)
nouv_fich.close
Set nouv_fich = fs.OpenTextFile(fichresult,8,false) 
nouv_fich.writeline("<html><title>"&Titre&"</title><HTA:APPLICATION SCROLL=""yes"" WINDOWSTATE=""Maximize""icon=""verifier.exe"">"&_
"<meta content=""text/html; charset=UTF-8"" http-equiv=""content-type"">"&_
"<body text=white bgcolor=#1234568><style type='text/css'>"&_
"a:link {color: #F19105;}"&_
"a:visited {color: #F19105;}"&_
"a:active {color: #F19105;}"&_
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}"&_
"</style>")
nouv_fich.writeline "<SCRIPT LANGUAGE=""VBScript"">"
nouv_fich.writeline "Function Explore(filename)"
nouv_fich.writeline "Set ws=CreateObject(""wscript.Shell"")"
nouv_fich.writeline "ws.run ""Explorer /n,/select,""&filename&"""""
nouv_fich.writeline "End Function"
nouv_fich.writeline "</script>"
 
'boucler sur les niveaux jusqu'à ce qu'il n'y ait 
'plus de sous répertoires dans le niveau
do while num>0 '------------------------------------
 
'recopie tabl
    redim tablold(ubound(tabl))
    for n=0 to ubound(tabl)
        tablold(n)=tabl(n)
    next
 
'réinitialiser tabl
    redim tabl(0)
    tabl(0)="zaza"
 
'explorer le ss répertoire
    for n=1 to ubound(tablold)
        expl(tablold(n)) 'ajoute ds le tableau tabl les ss rep de tablold(n)
    next
loop '----------------------------------------------
 
nouv_fich.writeline("</BODY></HTML>")
nouv_fich.close
set nouv_fich=nothing
nboct2= int(fs.getfolder(nomrep).size/1024)
set fs=nothing 
 
'afficher le résultat dans un MsgBox
Msgbox nbtot & " fichiers pour " & int(nboct/1024) & " ko dans """ & nomrep &_
""" et ses " & nbssrep & " sous-répertoires (total " & nboct2 & " ko)",64,Titre
 
Set sh = CreateObject("WScript.Shell") 
sh.run "explorer " & fichresult
set sh=nothing
'*************************************************************************
Function Parcourir_Dossier()
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "Veuillez choisir un dossier pour uploader son contenu",1,"c:\Programs")
    If objFolder Is Nothing Then
        Wscript.Quit
    End If
    NomDossier = objFolder.title
    Parcourir_Dossier = objFolder.self.path
end Function
'*************************************************************************
sub expl(nomfich) 
'ajoute dans le tableau tabl() tous les sous répertoires de nomfich
'et ajoute dans le fichier nouv_fich les noms des fichiers et leurs caractéristiques
 
    Set rep=fs.getFolder(nomfich)
    num=ubound(tabl)
'parcourir les sous répertoires de nomfich
    for each ssrep in rep.subfolders 
        num=num+1 
        redim preserve tabl(num)
        tabl(num)= ssrep.path
        nbssrep=nbssrep+1
    next 
'parcourir les fichiers de nomfich
    for each fich in rep.files 
        nbtot=nbtot+1
        nboct=nboct+fich.size
'**********************************************************************************************************************************************************************************************
'chercher dans le fichier (vous pouvez commenter cette ligne si vous voulez juste afficher les fichiers qui contient seulement le mot à rechercher)
nouv_fich.writeline fich.path & "<br><FONT COLOR=""yellow""><B>(" & int(fich.size/1024) & " ko, cr&eacute;&eacute; " & fich.DateCreated & ", acc " & fich.DateLastAccessed & ")</B></FONT><br>"
'**********************************************************************************************************************************************************************************************
        Dim Ext 
        'ici dans ce tableau vous pouvez ajouter d'autres extensions de type texte
        Ext = Array(".txt",".htm",".asp",".php",".rtf",".html",".htm",".hta",".xml",".doc",".docx",".csv",".vbs",".js",".css",".ini",".inf")
        For i=LBound(Ext) To UBound(Ext)
            if instr(lcase(fich.name),Ext(i)) > 0 Then 
                Set fich_sce = fs.OpenTextFile(fich.path,1,false,-2)
                txtlu=fich_sce.readall
                txtlu = HtmlEscape(txtlu)
                fich_sce.close
                'txtlu=tt(txtlu)
                pos=instr(lcase(txtlu),lcase(mot_cherch))
                if pos>0 then 
                    nouv_fich.writeline ("<BR><BR><A href=""#"" OnClick='Explore("""& fich.Path & """)'>" & fich.name & "</A>")
                    do while pos>0
                        nbav=50
                        if pos-1<nbav then nbav=pos-1
                        nbapr=50
                        if len(txtlu)-pos-len(mot_cherch)+1<nbapr then nbapr=len(txtlu)-pos-len(mot_cherch)+1
                        txx= tt(mid(txtlu,pos-nbav,nbav)) & "<FONT COLOR='Darkorange'><B>" & tt(mid(txtlu,pos,len(mot_cherch))) & "</B></FONT>" & mid(txtlu,pos+len(mot_cherch),nbapr)
                        if nbav=50 then txx="..." & txx
                        if nbapr=50 then txx=txx & "..."
                        txx="<BR>&nbsp;&nbsp;&nbsp;" & txx
                        nouv_fich.writeline txx
                        txtlu=right(txtlu,len(txtlu)-pos+1-len(mot_cherch))
                        pos=instr(lcase(txtlu),lcase(mot_cherch))
                    loop
                end if
            end if
        next 
    next
    set rep=nothing 
end sub
'*************************************************************************
function tt(txte)
    tt=txte
    tt=replace(tt,"<","&lt;")
    tt=replace(tt,">","&gt;")
end function
'*************************************************************************
Function HtmlEscape(strRawData) 
'http://alexandre.alapetite.fr/doc-alex/alx_special.html
Dim strHtmlEscape 
    strHtmlEscape = strRawData
    strHtmlEscape = Replace(strHtmlEscape, "&", "&amp;")
    strHtmlEscape = Replace(strHtmlEscape, "<", "&lt;")
    strHtmlEscape = Replace(strHtmlEscape, ">", "&gt;")
    strHtmlEscape = Replace(strHtmlEscape, """", "&quot;")
    strHtmlEscape = Replace(strHtmlEscape, "à", "&agrave;")
    strHtmlEscape = Replace(strHtmlEscape, "è", "&egrave;")
    strHtmlEscape = Replace(strHtmlEscape, "é", "&eacute;")
    strHtmlEscape = Replace(strHtmlEscape, "©", "&copy;")
    strHtmlEscape = Replace(strHtmlEscape, "ê", "&ecirc;")
    'strHtmlEscape = Replace(strHtmlEscape, vbCrLf, "<br>")
    'strHtmlEscape = Replace(strHtmlEscape, vbCr, "<br>")
    'strHtmlEscape = Replace(strHtmlEscape, vbLf, "<br>")
    'strHtmlEscape = Replace(strHtmlEscape, vbTab, "&nbsp;&nbsp;&nbsp;&nbsp;")
    'strHtmlEscape = Replace(strHtmlEscape, "  ", "&nbsp;&nbsp;")
    HtmlEscape = strHtmlEscape
End Function