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
| Option Explicit
'**************************************************************************************
' GetFileDlg() And GetFileDlgBar() by omen999 - may 2014 - http://omen999.developpez.com
' Universal Browse for files function
' compatibility : all versions windows and IE - supports start folder, filters and title
' note : the global size of the parameters cannot exceed 191 chars for GetFileDlg
'**************************************************************************************
Dim Title,sIniDir,sFilter,sTitle,InFile,WshShell,fso,URL,ProtocoleHTTP,LogFile,Data,i
Title = "Check URL © Hackoo 2014"
Set WshShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
sIniDir = WshShell.CurrentDirectory & "\url2check.txt"
sFilter = "Fichiers Textes (*.txt)|*.txt|Tous les fichiers (*.*)|*.*|"
sTitle = Title & " Parcourir le fichier texte"
'sIniDir must be conformed to the javascript syntax
InFile = GetFileDlg(Replace(sIniDir,"\","\\"),sFilter,sTitle)
LogFile = Left(Wscript.ScriptFullName,InstrRev(Wscript.ScriptFullName, ".")) & "log"
If fso.FileExists(LogFile) Then fso.DeleteFile LogFile
Data = ReadFileText(InFile)
MsgBox Data
URL = Split(Data,VbCrLF)
ProtocoleHTTP = "http://"
For i = LBound(URL) To UBound(URL)
If Left(URL(i),7) <> ProtocoleHTTP Then
URL(i) = ProtocoleHTTP & URL(i)
Call Check(URL(i))
Else
Call Check(URL(i))
End if
Next
Call Explorer(LogFile)
'****************************************************************************************************************
Sub Check(URL)
On Error Resume Next
Dim xmlhttp
Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
xmlhttp.open "HEAD",URL,False
xmlhttp.send
If Err = 0 Then
Select Case Cint(xmlhttp.status)
Case 200,202,301,302,401
Set xmlhttp = Nothing
Call WriteLog(DblQuote(URL) & VbTab &" ====> "& VbTab &" OK !")
Case Else
Set xmlhttp = Nothing
Call WriteLog(DblQuote(URL) & VbTab &" ====> "& VbTab & "**/!\** KO **/!\**")
End Select
Else
Call WriteLog(Err.Description)
End If
End Sub
'******************************************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'******************************************************************************************************************
Sub WriteLog(strText)
Dim fs,ts
Const ForAppending = 8
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "log", ForAppending, True)
ts.WriteLine strText
ts.Close
End Sub
'******************************************************************************************************************
Function GetFileDlg(sIniDir,sFilter,sTitle)
GetFileDlg=CreateObject("WScript.Shell").Exec("mshta.exe ""about:<object id=d classid=clsid:3050f4e1-98b5-11cf-bb82-00aa00bdce0b></object><script>moveTo(0,-9999);function window.onload(){var p=/[^\0]*/;new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).Write(p.exec(d.object.openfiledlg('" & sIniDir & "',null,'" & sFilter & "','" & sTitle & "')));close();}</script><hta:application showintaskbar=no />""").StdOut.ReadAll
End Function
'******************************************************************************************************************
Function ReadFileText(sFile)
Dim objFSO,oTS,sText
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oTS = objFSO.OpenTextFile(sFile)
sText = oTS.ReadAll
oTS.close
set oTS = nothing
Set objFSO = nothing
ReadFileText = sText
End Function
'******************************************************************************************************************
Function Explorer(File)
Dim ws
Set ws=CreateObject("wscript.shell")
ws.run "Explorer "& File & "\",1,True
end Function
'****************************************************************************************************************** |
