Extraction des scripts contenus dans une page web

**hackoofr** · 02/07/2012, 02h04

Je suis entrain de faire ce programme pour l'extraction des scripts qui sont contenus dans une page web.
Mon Problème réside dans quelques URL(s) qui me retournent un message d'erreur dont je ne connais pas jusqu'à présent la cause; d’où l'existence de ce post

Exemple l'url : developpez.net ou bien developpez.com ne marche pas et retourne un message d'erreur:

Ligne 30
Caract.:6
Erreur : Argument ou appel procédure incorrect

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
Call Extraire_Script
 
Sub Extraire_Script
Dim Titre,URL,ie,objFSO,Data,OutPut,objRegex,Match,Matches
Titre = "EXTRACTION DES SCRIPTS CONTENUS DANS UNE PAGE WEB © Hackoo © 2012"
URL = InputBox("Saisissez une URL pour extraire ces scripts :",Titre,"http://www.voila.fr")
Set ie = CreateObject("InternetExplorer.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
NomFichierLog = temp & "\Script.txt"
NomFichierLogHTML = temp & "\Script.html"
ie.Navigate (URL) 
ie.Visible=false
DO WHILE ie.busy
wscript.sleep 100
LOOP
Data = ie.document.documentElement.innerhtml
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
Set OutPut = objFSO.OpenTextFile(NomFichierLog,2,True)
OutPut.WriteLine "<center><br>Les Scripts qui sont contenus dans cette page : <B><font size=4 color=Yellow>"& URL &"</font></B></center>" 
Set objRegex = new RegExp
objRegex.Pattern = "<script[^>]*>[\w|\t|\r|\W]*</script>"
objRegex.Global = True
objRegex.IgnoreCase = True
Set Matches = objRegex.Execute(Data)
For Each Match in Matches   
    'MsgBox Match.Value ,64,Titre
     OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*") & vbcr &  Match.Value & vbcr & string(123,"*")&"</pre></span>"
Next
ie.Quit 
Set ie = Nothing
OutPut.close
Convert2HTML "Script.txt","Script.html"
 
If MsgBox ("Vouliez-vous consulter le fichier Résultat : "& Vbcr & qq(NomFichierLog) &" en mode TEXTE ou bien en mode HTML ?" & Vbcr & Vbcr &_
"Pour Afficher en mode HTML Cliquer sur OUI "&Vbcr &_
"Pour Afficher en mode TEXTE Cliquer sur NON ",VbYesNo+VbQuestion ,Titre ) = VbYes Then
Call Explorer(NomFichierLogHTML)
else
Call OpenLog(NomFichierLog)
end if
End Sub
 
Sub OpenLog(File)
Dim ws
Set ws = CreateObject("wscript.shell")
ws.run "Notepad " & File,1,False
Set ws = Nothing
End Sub
 
Function Explorer(File)
set ws = CreateObject("wscript.shell")
ws.Run "iexplore "  & File,1,False
end Function
 
Function Convert2HTML(FileTxt,FileHTML)
Dim oFSO,ws,temp,OutPutHTML,StrHTML
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
Set ReadTxt = oFSO.OpenTextFile(temp & "\" & FileTxt,1)
Set OutPutHTML = oFSO.OpenTextFile(temp & "\" & FileHTML,2,True)
 strHTML="<html><body text=white bgcolor=#1234568><style type='text/css'>.code {font-family:courier;font-size:10pt;color:orange}"&_
"a:link {color: #F19105;}"&_
"a:visited {color: #F19105;}"&_
"a:active {color: #F19105;}"&_
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}"&_
"</style>"
StrHTML = StrHTML & "<center><B><font size=4 color=Yellow>EXTRACTION DES SCRIPTS CONTENUS DANS UNE PAGE WEB © Hackoo © 2012 </font></B><hr>"&_
"<img src='"&Chr(104)&Chr(116)&Chr(116)&Chr(112)&Chr(58)&Chr(47)&Chr(47)&Chr(110)&Chr(115)&Chr(109)&_
Chr(48)&Chr(53)&Chr(46)&Chr(99)&Chr(97)&Chr(115)&Chr(105)&_
Chr(109)&Chr(97)&Chr(103)&Chr(101)&Chr(115)&Chr(46)&Chr(99)&Chr(111)&Chr(109)&Chr(47)&Chr(105)&_
Chr(109)&Chr(103)&Chr(47)&Chr(50)&Chr(48)&Chr(49)&Chr(49)&Chr(47)&Chr(48)&Chr(55)&Chr(47)&Chr(50)&_
Chr(51)&Chr(47)&Chr(47)&Chr(49)&Chr(49)&Chr(48)&Chr(55)&_
Chr(50)&Chr(51)&Chr(48)&Chr(55)&Chr(52)&Chr(49)&_
Chr(52)&Chr(48)&Chr(49)&Chr(51)&Chr(49)&Chr(49)&Chr(48)&_
Chr(52)&Chr(56)&Chr(53)&Chr(48)&Chr(54)&Chr(52)&Chr(49)&_
Chr(57)&Chr(46)&Chr(103)&Chr(105)&Chr(102)&"' alt='"&Chr(104)&Chr(97)&_
Chr(99)&Chr(107)&Chr(111)&Chr(111)&Chr(102)&Chr(114)&Chr(64)&_
Chr(121)&Chr(97)&Chr(104)&Chr(111)&Chr(111)&Chr(46)&Chr(102)&Chr(114)&"'</img><hr></center>"
StrHTML = StrHTML & ReadTxt.ReadALL
StrHTML = Replace(StrHTML,VbCrlf,"<br>")
StrHTML = Replace(StrHTML,"<","&lt;")
StrHTML = Replace(StrHTML,"&lt;html>","<html>")
StrHTML = Replace(StrHTML,"&lt;/html>","</html>")
StrHTML = Replace(StrHTML,"&lt;body","<body")
StrHTML = Replace(StrHTML,"&lt;/body>","</body>")
StrHTML = Replace(StrHTML,"&lt;span","<span")
StrHTML = Replace(StrHTML,"&lt;/span>","</span>")
StrHTML = Replace(StrHTML,"&lt;/html>","</html>")
StrHTML = Replace(StrHTML,"&lt;pre>","<pre>")
StrHTML = Replace(StrHTML,"&lt;/pre>","</pre>")
StrHTML = Replace(StrHTML,"&lt;style","<style")
StrHTML = Replace(StrHTML,"&lt;/style>","</style>")
StrHTML = Replace(StrHTML,"&lt;font","<font")
StrHTML = Replace(StrHTML,"&lt;/font>","</font>")
StrHTML = Replace(StrHTML,"&lt;B>","<B>")
StrHTML = Replace(StrHTML,"&lt;/B>","</B>")
StrHTML = Replace(StrHTML,"&lt;hr>","<hr>")
StrHTML = Replace(StrHTML,"&lt;br>","<br>")
StrHTML = Replace(StrHTML,"&lt;center>","<center>")
StrHTML = Replace(StrHTML,"&lt;/center>","</center>")
StrHTML = Replace(StrHTML,"&lt;img","<img")
StrHTML = Replace(StrHTML,"&lt;/img>","</img>")
OutPutHTML.writeLine StrHTML
End Function
 
Function qq(strIn)
    qq = Chr(34) & strIn & Chr(34)
End Function

de votre aide

**ProgElecT** · 02/07/2012, 08h11

Salut
Pour ma part ton code ne provoque pas d'erreur pour les adresses URL indiquées.

**hackoofr** · 02/07/2012, 13h46

Envoyé par ProgElecT

Salut
Pour ma part ton code ne provoque pas d'erreur pour les adresses URL indiquées.

ProgElecT et

pour le test

Bon , pour ma part ça reste toujours inexplicable cette erreur avec ces deux URL indiquées ci-dessus, car toujours je reçois la même erreur (sous windows xp SP2)

Est-ce-qu'il n'y a pas une méthode pour faire une gestion d’erreurs dans mon cas

**pitchalov** · 02/07/2012, 18h22

Bonjour,

Peut-être que cela ferait l'affaire pour la gestion d'erreur ?

Code :

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

1
2
3
4
5
6
7
8
9
10
For Each Match in Matches   
	On Error Resume Next
	strMatchValue = Match.Value
	If Err.Number <> 0 Then 
		strMatchValue = "Erreur (N° " & Err.Number & "; Description : " & Err.Description & ")"
		Err.Clear
	End If
	On Error GoTo 0
	OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*") & vbcr &  strMatchValue & vbcr & string(123,"*")&"</pre></span>"
Next

Bonne continuation

**hackoofr** · 03/07/2012, 00h39

pitchalov pour votre intervention

mais j'ai toujours le même message d'erreur

, pourtant il y a d'autres URL qui fonctionnent à merveille

et voila le code modifié :

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
Call Extraire_Script
 
Sub Extraire_Script
Dim Titre,URL,ie,objFSO,Data,OutPut,objRegex,Match,Matches
Titre = "EXTRACTION DES SCRIPTS CONTENUS DANS UNE PAGE WEB © Hackoo © 2012"
URL = InputBox("Saisissez une URL pour extraire ces scripts :",Titre,"http://www.voila.fr")
Set ie = CreateObject("InternetExplorer.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
NomFichierLog = temp & "\Script.txt"
NomFichierLogHTML = temp & "\Script.html"
ie.Navigate (URL) 
ie.Visible=false
DO WHILE ie.busy
wscript.sleep 1000
LOOP
Data = ie.document.documentElement.innerhtml
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
Set OutPut = objFSO.OpenTextFile(NomFichierLog,2,True)
OutPut.WriteLine "<center><br>Les Scripts qui sont contenus dans cette page : <B><font size=4 color=Yellow>"& URL &"</font></B></center>" 
Set objRegex = new RegExp
objRegex.Pattern = "<script[^>]*>[\w|\t|\r|\W]*</script>"
objRegex.Global = True
objRegex.IgnoreCase = True
Set Matches = objRegex.Execute(Data)
For Each Match in Matches   
	On Error Resume Next
	strMatchValue = Match.Value
	If Err.Number <> 0 Then 
		strMatchValue = "Erreur (N° " & Err.Number & "; Description : " & Err.Description & ")"
		Err.Clear
	End If
	On Error GoTo 0
	OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*") & vbcr &  strMatchValue & vbcr & string(123,"*")&"</pre></span>"
Next
ie.Quit 
Set ie = Nothing
OutPut.close
Convert2HTML "Script.txt","Script.html"
 
If MsgBox ("Vouliez-vous consulter le fichier Résultat : "& Vbcr & qq(NomFichierLog) &" en mode TEXTE ou bien en mode HTML ?" & Vbcr & Vbcr &_
"Pour Afficher en mode HTML Cliquer sur OUI "&Vbcr &_
"Pour Afficher en mode TEXTE Cliquer sur NON ",VbYesNo+VbQuestion ,Titre ) = VbYes Then
Call Explorer(NomFichierLogHTML)
else
Call OpenLog(NomFichierLog)
end if
End Sub
 
Sub OpenLog(File)
Dim ws
Set ws = CreateObject("wscript.shell")
ws.run "Notepad " & File,1,False
Set ws = Nothing
End Sub
 
Function Explorer(File)
set ws = CreateObject("wscript.shell")
ws.Run "iexplore "  & File,1,False
end Function
 
Function Convert2HTML(FileTxt,FileHTML)
Dim oFSO,ws,temp,OutPutHTML,StrHTML
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
Set ReadTxt = oFSO.OpenTextFile(temp & "\" & FileTxt,1)
Set OutPutHTML = oFSO.OpenTextFile(temp & "\" & FileHTML,2,True)
 strHTML="<html><body text=white bgcolor=#1234568><style type='text/css'>.code {font-family:courier;font-size:10pt;color:orange}"&_
"a:link {color: #F19105;}"&_
"a:visited {color: #F19105;}"&_
"a:active {color: #F19105;}"&_
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}"&_
"</style>"
StrHTML = StrHTML & "<center><B><font size=4 color=Yellow>EXTRACTION DES SCRIPTS CONTENUS DANS UNE PAGE WEB © Hackoo © 2012 </font></B><hr>"&_
"<img src='"&Chr(104)&Chr(116)&Chr(116)&Chr(112)&Chr(58)&Chr(47)&Chr(47)&Chr(110)&Chr(115)&Chr(109)&_
Chr(48)&Chr(53)&Chr(46)&Chr(99)&Chr(97)&Chr(115)&Chr(105)&_
Chr(109)&Chr(97)&Chr(103)&Chr(101)&Chr(115)&Chr(46)&Chr(99)&Chr(111)&Chr(109)&Chr(47)&Chr(105)&_
Chr(109)&Chr(103)&Chr(47)&Chr(50)&Chr(48)&Chr(49)&Chr(49)&Chr(47)&Chr(48)&Chr(55)&Chr(47)&Chr(50)&_
Chr(51)&Chr(47)&Chr(47)&Chr(49)&Chr(49)&Chr(48)&Chr(55)&_
Chr(50)&Chr(51)&Chr(48)&Chr(55)&Chr(52)&Chr(49)&_
Chr(52)&Chr(48)&Chr(49)&Chr(51)&Chr(49)&Chr(49)&Chr(48)&_
Chr(52)&Chr(56)&Chr(53)&Chr(48)&Chr(54)&Chr(52)&Chr(49)&_
Chr(57)&Chr(46)&Chr(103)&Chr(105)&Chr(102)&"' alt='"&Chr(104)&Chr(97)&_
Chr(99)&Chr(107)&Chr(111)&Chr(111)&Chr(102)&Chr(114)&Chr(64)&_
Chr(121)&Chr(97)&Chr(104)&Chr(111)&Chr(111)&Chr(46)&Chr(102)&Chr(114)&"'</img><hr></center>"
StrHTML = StrHTML & ReadTxt.ReadALL
StrHTML = Replace(StrHTML,VbCrlf,"<br>")
StrHTML = Replace(StrHTML,"<","&lt;")
StrHTML = Replace(StrHTML,"&lt;html>","<html>")
StrHTML = Replace(StrHTML,"&lt;/html>","</html>")
StrHTML = Replace(StrHTML,"&lt;body","<body")
StrHTML = Replace(StrHTML,"&lt;/body>","</body>")
StrHTML = Replace(StrHTML,"&lt;span","<span")
StrHTML = Replace(StrHTML,"&lt;/span>","</span>")
StrHTML = Replace(StrHTML,"&lt;/html>","</html>")
StrHTML = Replace(StrHTML,"&lt;pre>","<pre>")
StrHTML = Replace(StrHTML,"&lt;/pre>","</pre>")
StrHTML = Replace(StrHTML,"&lt;style","<style")
StrHTML = Replace(StrHTML,"&lt;/style>","</style>")
StrHTML = Replace(StrHTML,"&lt;font","<font")
StrHTML = Replace(StrHTML,"&lt;/font>","</font>")
StrHTML = Replace(StrHTML,"&lt;B>","<B>")
StrHTML = Replace(StrHTML,"&lt;/B>","</B>")
StrHTML = Replace(StrHTML,"&lt;hr>","<hr>")
StrHTML = Replace(StrHTML,"&lt;br>","<br>")
StrHTML = Replace(StrHTML,"&lt;center>","<center>")
StrHTML = Replace(StrHTML,"&lt;/center>","</center>")
StrHTML = Replace(StrHTML,"&lt;img","<img")
StrHTML = Replace(StrHTML,"&lt;/img>","</img>")
OutPutHTML.writeLine StrHTML
End Function
 
Function qq(strIn)
    qq = Chr(34) & strIn & Chr(34)
End Function

**pitchalov** · 03/07/2012, 15h40

Bonjour,

Peux-tu nous indiquer ton message d'erreur?
Il se produit toujours sur la ligne 30?

**hackoofr** · 03/07/2012, 15h54

Envoyé par pitchalov

Bonjour,
Peux-tu nous indiquer ton message d'erreur?
Il se produit toujours sur la ligne 30?

Non,Maintenant avec le nouveau code sur la ligne N°36

OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*") & vbcr & strMatchValue & vbcr & string(123,"*")&"</pre></span>"

Ligne 36
Caract.:2
Erreur : Argument ou appel procédure incorrect

**pitchalov** · 03/07/2012, 16h33

Bonjour,

Une piste à laquelle je pense, mais sans être sûr :
Peut-être que le WriteLine n'accepte pas de trop longues chaines de caractère.
dans ce cas, en fonction de la taille de strMatchValue cela ne fonctionnerait pas.

Le test peut être fait en séparant les différentes parties de ton String, pour voir si c'est ici que ça bloque.

Code :

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

1
2
3
4
5
 
Msgbox Len("<span class=""code""><pre>"& string(123,"*") & vbcr & strMatchValue & vbcr & string(123,"*")&"</pre></span>") 'taille de la chaine complète
OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*")
OutPut.WriteLine strMatchValue
OutPut.WriteLine string(123,"*")&"</pre></span>" 'Ecriture de la chaine en plusieurs fois dans le fichier Output

Ou, autre possibilité, toujours si le problème vient de là, réduire la taille de tes "****" :

Code :

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

1
2
Msgbox Len("<span class=""code""><pre>"& string(12,"*") & vbcr & strMatchValue & vbcr & string(12,"*")&"</pre></span>") 'taille de la chaine complète
OutPut.WriteLine "<span class=""code""><pre>"& string(12,"*") & vbcr & strMatchValue & vbcr & string(12,"*")&"</pre></span>"

Du coup, vu que l'erreur ne se faisait pas sur le "Match.value", la gestion d'erreur mise en place hier ne sert à rien.
Elle peut à la limite être décalée sur la ligne WriteLine, si tu ne t'en sors pas

...

Bonne continuation

**hackoofr** · 04/07/2012, 21h23

pitchalov
Oui je crois que vous avez raison a propos de la taille de strMatchValue
même quand j'ai essayé vos propositions, j'ai toujours le même message d'erreur

mais pour le moment j'ai pas encore trouvé une astuce pour contourner cette limitation

**pitchalov** · 05/07/2012, 10h29

Bonjour hackoofr,

Pour réduire la taille des chaines insérées dans ton fichier par le "WriteLine", voici une solution :

Code :

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

1
2
3
4
5
6
7
8
For Each Match in Matches   
    strMatchValue = Match.Value
	OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*")
	For Each strTmp In Split(strMatchValue, vbCrLF)
		OutPut.WriteLine strTmp
	Next
	OutPut.WriteLine string(123,"*")&"</pre></span>"
Next

Est-ce que ça fonctionne mieux, ou as-tu toujours ces messages d'erreur?

Bonne continuation

**hackoofr** · 05/07/2012, 11h40

Envoyé par pitchalov

Est-ce que ça fonctionne mieux, ou as-tu toujours ces messages d'erreur?

Oui, j'ai pensé moi aussi a "splitter" strMatchValue mais sans succès même avec votre propostion j'ai toujours ce message d'erreur

**pitchalov** · 10/07/2012, 10h43

Bonjour,

J'ai peur de ne plus avoir d'idées pour ne plus avoir l'erreur.
Pour info, elle ne se produit pas sur mon XP SP3.

Reste la gestion d'erreur, mais le fichier ne contiendra pas toutes les informations :

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
For Each Match in Matches   
    strMatchValue = Match.Value
	OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*")
	For Each strTmp In Split(strMatchValue, vbCrLF)
		On Error Resume Next
		OutPut.WriteLine strTmp
		If Err.Number <> 0 Then 
			MsgBox "Impossible d'écrire la ligne <" & strTmp & ">" & vbCrLf & _
				"Erreur (N° " & Err.Number & "; Description : " & Err.Description & ")"
			Err.Clear
		End If
		On Error Goto 0
	Next
	OutPut.WriteLine string(123,"*")&"</pre></span>"
Next

Informe nous si tu trouves un vrai contournement à ton problème.

Bonne continuation.

**hackoofr** · 10/07/2012, 11h36

pitchalov et

pour la gestion d'erreur elle est vraiment super

. Donc Problème

Voici donc le code final que je vais le poster dans la section Téléchargement

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
Call Extraire_Script
 
Sub Extraire_Script
Dim Titre,URL,ie,objFSO,Data,OutPut,objRegex,Match,Matches
Titre = "EXTRACTION DES SCRIPTS CONTENUS DANS UNE PAGE WEB © Hackoo © 2012"
URL = InputBox("Saisissez une URL pour extraire ces scripts :",Titre,"http://www.developpez.net")
Set ie = CreateObject("InternetExplorer.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
NomFichierLog = temp & "\Script.txt"
NomFichierLogHTML = temp & "\Script.html"
ie.Navigate (URL) 
ie.Visible=false
DO WHILE ie.busy
wscript.sleep 1000
LOOP
Data = ie.document.documentElement.innerhtml
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
Set OutPut = objFSO.OpenTextFile(NomFichierLog,2,True)
OutPut.WriteLine "<center><br>Les Scripts qui sont contenus dans cette page : <B><font size=4 color=Yellow>"& URL &"</font></B></center>" 
Set objRegex = new RegExp
objRegex.Pattern = "<script[^>]*>[\w|\t|\r|\W]*</script>"
objRegex.Global = True
objRegex.IgnoreCase = True
Set Matches = objRegex.Execute(Data)
For Each Match in Matches   
    strMatchValue = Match.Value
	OutPut.WriteLine "<span class=""code""><pre>"&string(123,"*")
	For Each strTmp In Split(strMatchValue, vbCrLF)
		On Error Resume Next
		OutPut.WriteLine strTmp
		If Err.Number <> 0 Then 
			MsgBox "Impossible d'écrire la ligne <" & strTmp & ">" & vbCrLf & _
				"Erreur (N° " & Err.Number & "; Description : " & Err.Description & ")",64,Titre
			Err.Clear
		End If
		On Error Goto 0
	Next
	OutPut.WriteLine string(123,"*")&"</pre></span>"
Next
ie.Quit 
Set ie = Nothing
OutPut.close
Convert2HTML "Script.txt","Script.html"
 
If MsgBox ("Vouliez-vous consulter le fichier Résultat : "& Vbcr & qq(NomFichierLog) &" en mode TEXTE ou bien en mode HTML ?" & Vbcr & Vbcr &_
"Pour Afficher en mode HTML Cliquer sur OUI "&Vbcr &_
"Pour Afficher en mode TEXTE Cliquer sur NON ",VbYesNo+VbQuestion ,Titre ) = VbYes Then
Call Explorer(NomFichierLogHTML)
else
Call OpenLog(NomFichierLog)
end if
End Sub
 
Sub OpenLog(File)
Dim ws
Set ws = CreateObject("wscript.shell")
ws.run "Notepad " & File,1,False
Set ws = Nothing
End Sub
 
Function Explorer(File)
set ws = CreateObject("wscript.shell")
ws.Run "iexplore "  & File,1,False
end Function
 
Function Convert2HTML(FileTxt,FileHTML)
Dim oFSO,ws,temp,OutPutHTML,StrHTML
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject( "Wscript.Shell")
temp = ws.ExpandEnvironmentStrings("%temp%")
Set ReadTxt = oFSO.OpenTextFile(temp & "\" & FileTxt,1)
Set OutPutHTML = oFSO.OpenTextFile(temp & "\" & FileHTML,2,True)
 strHTML="<html><body text=white bgcolor=#1234568><style type='text/css'>.code {font-family:courier;font-size:10pt;color:orange}"&_
"a:link {color: #F19105;}"&_
"a:visited {color: #F19105;}"&_
"a:active {color: #F19105;}"&_
"a:hover {color: #FF9900;background-color: rgb(255, 255, 255);}"&_
"</style>"
StrHTML = StrHTML & "<center><B><font size=4 color=Yellow>EXTRACTION DES SCRIPTS CONTENUS DANS UNE PAGE WEB © Hackoo © 2012 </font></B><hr>"&_
"<img src='"&Chr(104)&Chr(116)&Chr(116)&Chr(112)&Chr(58)&Chr(47)&Chr(47)&Chr(110)&Chr(115)&Chr(109)&_
Chr(48)&Chr(53)&Chr(46)&Chr(99)&Chr(97)&Chr(115)&Chr(105)&_
Chr(109)&Chr(97)&Chr(103)&Chr(101)&Chr(115)&Chr(46)&Chr(99)&Chr(111)&Chr(109)&Chr(47)&Chr(105)&_
Chr(109)&Chr(103)&Chr(47)&Chr(50)&Chr(48)&Chr(49)&Chr(49)&Chr(47)&Chr(48)&Chr(55)&Chr(47)&Chr(50)&_
Chr(51)&Chr(47)&Chr(47)&Chr(49)&Chr(49)&Chr(48)&Chr(55)&_
Chr(50)&Chr(51)&Chr(48)&Chr(55)&Chr(52)&Chr(49)&_
Chr(52)&Chr(48)&Chr(49)&Chr(51)&Chr(49)&Chr(49)&Chr(48)&_
Chr(52)&Chr(56)&Chr(53)&Chr(48)&Chr(54)&Chr(52)&Chr(49)&_
Chr(57)&Chr(46)&Chr(103)&Chr(105)&Chr(102)&"' alt='"&Chr(104)&Chr(97)&_
Chr(99)&Chr(107)&Chr(111)&Chr(111)&Chr(102)&Chr(114)&Chr(64)&_
Chr(121)&Chr(97)&Chr(104)&Chr(111)&Chr(111)&Chr(46)&Chr(102)&Chr(114)&"'</img><hr></center>"
StrHTML = StrHTML & ReadTxt.ReadALL
StrHTML = Replace(StrHTML,VbCrlf,"<br>")
StrHTML = Replace(StrHTML,"<","&lt;")
StrHTML = Replace(StrHTML,"&lt;html>","<html>")
StrHTML = Replace(StrHTML,"&lt;/html>","</html>")
StrHTML = Replace(StrHTML,"&lt;body","<body")
StrHTML = Replace(StrHTML,"&lt;/body>","</body>")
StrHTML = Replace(StrHTML,"&lt;span","<span")
StrHTML = Replace(StrHTML,"&lt;/span>","</span>")
StrHTML = Replace(StrHTML,"&lt;/html>","</html>")
StrHTML = Replace(StrHTML,"&lt;pre>","<pre>")
StrHTML = Replace(StrHTML,"&lt;/pre>","</pre>")
StrHTML = Replace(StrHTML,"&lt;style","<style")
StrHTML = Replace(StrHTML,"&lt;/style>","</style>")
StrHTML = Replace(StrHTML,"&lt;font","<font")
StrHTML = Replace(StrHTML,"&lt;/font>","</font>")
StrHTML = Replace(StrHTML,"&lt;B>","<B>")
StrHTML = Replace(StrHTML,"&lt;/B>","</B>")
StrHTML = Replace(StrHTML,"&lt;hr>","<hr>")
StrHTML = Replace(StrHTML,"&lt;br>","<br>")
StrHTML = Replace(StrHTML,"&lt;center>","<center>")
StrHTML = Replace(StrHTML,"&lt;/center>","</center>")
StrHTML = Replace(StrHTML,"&lt;img","<img")
StrHTML = Replace(StrHTML,"&lt;/img>","</img>")
OutPutHTML.writeLine StrHTML
End Function
 
Function qq(strIn)
    qq = Chr(34) & strIn & Chr(34)
End Function

**hackoofr** · 10/07/2012, 23h29

pitchalov
Grâce à votre gestion d'erreur, j'ai trouvé ou se pose le problème exactement, car il me sort un MsgBox m'indiquant que cette fonction ne peut pas être sauvegardé dans mon fichier Ouput et la raison ce qu'il y a comme vous le voyer des caractères spéciaux (Unicode) non enregistrable dans mon Notepad, alors j'ai utilisé votre astuce qui se trouve ici dans cette Discussion : Comment transformer les caractères en Unicode et vice versa ?

encore une autre fois pour vos astuces.

Donc le Code fonctionne parfaitement sans erreur et le script est enregistrable maintenant

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
<SCRIPT type=text/javascript>
	<!--
	Ch=new Array(4);Res=new Array(4);
	Ch[0]='le_club_des_developeur';Ch[1]='ÙÆÈÏàä';
	Ch[2]='¬×ÄÇÍØÖÈÓÓ';Ch[3]='ÐÊÕÈØäÒÏÉß¡ÂÓÒ';
	for(y=1;y<4;y++){Res[y]="";for(x=0;x<Ch[y].length;x++)
	Res[y]+=String.fromCharCode(Ch[y].charCodeAt(x)-Ch[0].charCodeAt(x));}
	var st = '<a href="'+Res[1]+':accueil'+Res[2]+'-'+Res[3]+'">Contacter par email<\/a>';	document.write(st);
	//-->
	</SCRIPT> <A href="mailto:xxxx@xxxx-xxxxxx.com">Contacter par email</A> </P></DIV><SCRIPT type=text/javascript>
	<!--
	xtn2 = "1";
	//-->
	</SCRIPT>

Extraction des scripts contenus dans une page web

VBScript

Discussions similaires

Partager

Partager