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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
| ''------------------------------------------------------------------------------------------------------------------
' TELECHARGEMENT des AIRES de CCI en format HTML ou PDF
'------------------------------------------------------------------------------------------------------------------
Option Explicit
Const ForReading = 1, ForWriting = 2 , ForAppending = 8
Dim SA 'Shell application
Dim WSH 'WScript.Shell
Dim FSO 'File system object
Dim FSO_DEBUG,FILE_DEBUG
Const maxTime = 30 ' in seconds
Const sleepTime = 250 ' in milliseconds
Dim PDFCreator, DefaultPrinter, ReadyState, c, Scriptname
Dim objArgs
Set SA = CreateObject("Shell.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = WScript.CreateObject("WScript.Shell")
'***********************************************************************************************
' --------> lecture des parametres
' Verification des données tout doit etre correct nom fichier repertoire source repertoire cible
'***********************************************************************************************
Scriptname = fso.GetbaseName(Wscript.ScriptFullname) 'nom du programme
Set objArgs = Wscript.Arguments
if not WScript.Arguments.Count = 3 then
Msgbox "Aucun parametre il manque un ou des parametres : adresse URL et/ou path fichier en sortie ",vbCritical,(Scriptname & " 025")
Wscript.quit 999
End if
FILE_DEBUG = objArgs(2)
Set FSO_DEBUG = FSO.OpenTextFile(FILE_DEBUG,ForAppending,true)
'***********************************************************************************************
'Controle si repertoire existe si non creation du repertoire
'***********************************************************************************************
If not FSO.FolderExists(FSO.getparentfoldername(objArgs(1) ) ) then
Call Create_folder ( FSO.getparentfoldername(objArgs(1) ) )
End If
'***********************************************************************************************
' Suppression du fichier cible si existe
'***********************************************************************************************
If FSO.Fileexists(objArgs(1)) Then
FSO.DeleteFile (objArgs(1))
End If
Select case Ucase( FSO.GetExtensionname(objArgs(1)) )
case "HTML"
Call Traitement_HTML
'msgbox "FIN de TRAITEMENT HTML"
FSO_DEBUG.close
wscript.quit 0
Case "PDF"
Call Traitement_PDF
'msgbox "FIN de TRAITEMENT PDF"
FSO_DEBUG.close
wscript.quit 0
Case Else
FSO_DEBUG.writeline Scriptname & " 55 -> Erreur type de fichier a telecharger = " & objargs(1)
FSO_DEBUG.close
wscript.quit 9
End Select
'------------------------------------------------------------------------------------
' traitement fichier HTML
'--------------------------------------------------------------------------------------
Sub Traitement_HTML
On Error Resume Next
'***********************************************************************************************
' Recuperation fichier format HTML
'***********************************************************************************************
dim xHttp: Set xHttp = createobject("Microsoft.XMLHTTP")
dim bStrm: Set bStrm = createobject("Adodb.Stream")
xHttp.Open "GET", objargs(0), False
'msgbox 70 & Err.number
xHttp.Send
'msgbox 72 & Err.number
If Err.Number <> 0 then
'--> pb connection internet on delete le fichier
FSO_DEBUG.writeline Scriptname & " 68 -> Erreur = " & Err.Number & "download fichier HTML = " & objargs(0)
'WScript.Echo "59 Unexpected Error #: " & Err.Number
FSO_DEBUG.close
FSO.Deletefile objargs(0) , true
wscript.quit 9
End if
with bStrm
.type = 1 '//binary
.open
'msgbox 82 & Err.number
.write xHttp.responseBody
.savetofile (objArgs(1)), 2 '//overwrite
'.savetofile "D:\PROGRAMMES_BATCH_VBS\PROGRAMMES\Aires_gege\Resultat\Aires_00.html", 2 '//overwrite
end with
On Error GoTo 0
End sub
'------------------------------------------------------------------------------------
' traitement fichier PDF
'--------------------------------------------------------------------------------------
Sub Traitement_PDF
On Error Resume Next
'msgbox "jepasse 01" & objargs(0) & vbcrlf & objargs(1)
If CDbl(Replace(WScript.Version,".",",")) < 5.1 then
msgbox "You need the ""Windows Scripting Host version 5.1"" or greater!", vbCritical + vbSystemModal, AppTitle
Wscript.Quit 9
End if
'***********************************************************************************************
' Controle si fichier Internet disponible
'***********************************************************************************************
dim xHttp: Set xHttp = createobject("Microsoft.XMLHTTP")
xHttp.Open "GET", objargs(0), False
If Err.Number <> 0 then
'--> pb connection internet on delete le fichier
FSO_DEBUG.writeline Scriptname & " 108 -> Erreur = " & Err.Number & "download fichier PDF = " & objargs(0)
'WScript.Echo "59 Unexpected Error #: " & Err.Number
FSO_DEBUG.close
FSO.Deletefile objargs(1) , true
wscript.quit 9
End if
xHttp.Send
'msgbox 72 & Err.number
If Err.Number <> 0 then
'--> pb connection internet on delete le fichier
FSO_DEBUG.writeline Scriptname & " 117 -> Erreur = " & Err.Number & "download fichier PDF = " & objargs(0)
'WScript.Echo "59 Unexpected Error #: " & Err.Number
FSO_DEBUG.close
FSO.Deletefile objargs(1) , true
wscript.quit 9
End if
'msgbox "jepasse 02"
Set PDFCreator = Wscript.CreateObject("PDFCreator.clsPDFCreator", "PDFCreator_")
PDFCreator.cStart "/NoProcessingAtStartup"
With PDFCreator
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveFormat") = 0 ' 0 = PDF
DefaultPrinter = .cDefaultprinter
.cDefaultprinter = "PDFCreator"
.cClearcache
End With
'msgbox "jepasse 03"
On Error Resume Next
With PDFCreator
'msgbox "jepasse 04"
On Error Resume Next
ReadyState = 0
'.cOption("AutosaveDirectory") = fso.GetParentFolderName(Wscript.ScriptFullname)
.cOption("AutosaveDirectory") = FSO.getparentfoldername(objArgs(1))
'msgbox "coptiondirectory" & Err.Number
.cOption("AutosaveFilename") = FSO.getfilename(objArgs(1))
'msgbox "coptionsave" & Err.Number
'.cPrintURL "http://www.campingcar-infos.com/Francais/listingairea.php?AS=on&ASN=on&AA=on&AC=on&ACF=on&ACS=on&APCC=on&AP=on&APN=on&pays=FRANCE&dept=48&textdept=48"
.cprintURL objArgs(0)
'msgbox "URL" & Err.Number
If Err.Number <> 0 then '--> pb connection internet on delete le fichier
FSO_DEBUG.writeline Scriptname & " 124 -> Erreur = " & Err.Number & "Probleme download fichier PDF = " & objargs(0)
'WScript.Echo "59 Unexpected Error #: " & Err.Number
FSO_DEBUG.close
FSO.Deletefile objargs(1) , true
wscript.quit 9
End if
WScript.Sleep 5000
.cCombineAll
.cPrinterStop = false
c = 0
Do While (ReadyState = 0) and (c < (maxTime * 1000 / sleepTime))
c = c + 1
Wscript.Sleep sleepTime
Loop
'msgbox "jepasse 05" & Zfile
If ReadyState = 0 then
MsgBox "Converting: " & objArgs(1) & vbcrlf & vbcrlf & _
"An error is occured: Time is up!", vbExclamation + vbSystemModal, scriptname
wscript.quit 999
End If
End With
'msgbox "jepasse 06"
With PDFCreator
'msgbox "jepasse 07" & DefaultPrinter
.cDefaultprinter = DefaultPrinter
.cClearcache
WScript.Sleep 200
.cClose
End With
'msgbox 153 & Err.Number
If Err.Number <> 0 then
'--> pb connection internet on delete le fichier
FSO_DEBUG.writeline Scriptname & " 157 -> Erreur = " & Err.Number & "Probleme download fichier PDF = " & objargs(0)
'WScript.Echo "59 Unexpected Error #: " & Err.Number
FSO_DEBUG.close
FSO.Deletefile objargs(1) , true
wscript.quit 9
End if
'msgbox "jepasse 08"
On Error GoTo 0
End sub
'--- PDFCreator events ---
Public Sub PDFCreator_eReady()
ReadyState = 1
End Sub
Public Sub PDFCreator_eError()
MsgBox "An error is occured!" & vbcrlf & vbcrlf & _
"Error [" & PDFCreator.cErrorDetail("Number") & "]: " & PDFcreator.cErrorDetail("Description"), vbCritical + vbSystemModal, Scriptname
Wscript.Quit 999
End Sub
'-----------------------------------------------------------------------------------------------
'------> 'creation nouveau repertoire
'-----------------------------------------------------------------------------------------------
Sub Create_folder(Chemin )
If Not fso.FolderExists(chemin) Then
call Create_folder(fso.GetParentFolderName(chemin))
fso.CreateFolder(chemin)
End If
End Sub |
