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
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
| ' ----------------------------------------------------------------------
' 1 Déclaration Functions de l'API Windows Fichiers
' ----------------------------------------------------------------------
' -----------------------
' 1.a Les Constantes
' -----------------------
Const MAX_PATH = 260
Const INVALID_HANDLE_VALUE = -1
' File Attributes
Const FILE_ATTRIBUTE_READONLY = &H1 ' 1
Const FILE_ATTRIBUTE_HIDDEN = &H2 ' 2
Const FILE_ATTRIBUTE_SYSTEM = &H4 ' 4
Const FILE_ATTRIBUTE_DIRECTORY = &H10 ' 16
Const FILE_ATTRIBUTE_ARCHIVE = &H20 ' 32
Const FILE_ATTRIBUTE_ENCRYPTED = &H40 ' 64
Const FILE_ATTRIBUTE_NORMAL = &H80 ' 128
Const FILE_ATTRIBUTE_TEMPORARY = &H100 ' 256
Const FILE_ATTRIBUTE_SPARSE_FILE = &H200 ' 512
Const FILE_ATTRIBUTE_REPARSE_POINT = &H400 ' 1024
Const FILE_ATTRIBUTE_COMPRESSED = &H800 ' 2048
Const FILE_ATTRIBUTE_OFFLINE = &H1000 ' 4096
' File Creation flags
Const CREATE_NEW = 1
Const CREATE_ALWAYS = 2
Const OPEN_EXISTING = 3
Const OPEN_ALWAYS = 4
Const TRUNCATE_EXISTING = 5
' FormatMessage
Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" ( _
ByVal dwFlags As Long, ByVal lpSource As Long, _
ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, ByVal nSize As Long, _
ByVal Arguments As Long) As Long
' -----------------------
' 1.b Les Fonctions
' -----------------------
Private Declare Function OpenFile Lib "kernel32.dll" Alias "OpenFileA" _
(ByVal lpFileName As String, ByVal lpReOpenBuff As Long, _
ByVal uStyle) As Long
Private Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" ( _
ByVal lpFileName As String, ByVal dwAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttr As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagAndAttr As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hHandle As Long) As Long
Private Declare Function WriteFile Lib "kernel32.dll" ( _
ByVal hFile As Long, ByVal buffer As String, _
ByVal dwBytesToWrite As Long, ByRef lpdwBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long
' ----------------------------------------------------------------------
' 2 Déclaration Functions de l'API Windows Internet/ftp
' ----------------------------------------------------------------------
' -----------------------
' 2.a Les Constantes
' -----------------------
Const INTERNET_FLAG_TRANSFER_ASCII = &H1 ' 0x00000001
Const FTP_TRANSFER_TYPE_ASCII = &H1 ' 0x00000001
Const INTERNET_FLAG_TRANSFER_BINARY = &H2 ' 0x00000002
Const FTP_TRANSFER_TYPE_BINARY = &H2 ' 0x00000002
Const GENERIC_READ = &H80000000 ' (0x80000000L)
Const GENERIC_WRITE = &H40000000 ' (0x40000000L)
Const INTERNET_FLAG_RAW_DATA = &H40000000 ' FTP/gopher find: receive the item _
'as raw (structured) data
Const INTERNET_DEFAULT_FTP_PORT = 21 ' default for FTP servers
Const INTERNET_DEFAULT_GOPHER_PORT = 70 ' " " gopher "
Const INTERNET_DEFAULT_HTTP_PORT = 80 ' " " HTTP "
Const INTERNET_DEFAULT_HTTPS_PORT = 443 ' " " HTTPS "
Const INTERNET_DEFAULT_SOCKS_PORT = 1080 ' default for SOCKS firewall servers.
' access types for InternetOpen()
Const INTERNET_OPEN_TYPE_PRECONFIG = 0 ' use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1 ' direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3 ' via named proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java/script/INS
' service types for InternetConnect()
Const INTERNET_SERVICE_URL = 0
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_SERVICE_GOPHER = 2
Const INTERNET_SERVICE_HTTP = 3
'Query Info
Const HTTP_QUERY_STATUS_CODE = 19 ' Status Code returned by Server
Const HTTP_QUERY_STATUS_TEXT = 20 '
' -----------------------
' 2.b Les Fonctions
' -----------------------
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, _
ByVal sProxyName As String, ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, ByVal sUserName As String, _
ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" _
(ByVal hconnect As Long, ByVal lpszVerb As String, ByVal lpszObjectName As String, _
ByVal lpszVersion As String, ByVal lpszReferer As Long, _
ByVal lpszAcceptTypes As Long, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" _
(ByVal hRequest As Long, ByVal lpszHeaders As String, ByVal dwHdrLength As Long, _
ByVal lpOptional As String, ByVal dwOptionalLength As Long) As Long
' HttpSendRequest sans lpOptional As String.
' à la place on met lpOptional As Long, pour pouvoir passer un pointeur NULL
Private Declare Function HttpSendRequest2 Lib "wininet.dll" Alias "HttpSendRequestA" _
(ByVal hRequest As Long, ByVal lpszHeaders As Long, ByVal dwHdrLength As Long, _
ByVal lpOptional As Long, ByVal dwOptionalLength As Long) As Long
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" _
(ByVal hRequest As Long, ByVal dwInfoLevel As Long, _
ByVal lpvBuffer As String, ByRef lpdwBufferLength As Long, _
ByRef lpdwIndex As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _
(ByVal hconnect As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, _
ByVal dwHdrLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetOpenUrl2 Lib "wininet.dll" Alias "InternetOpenUrlA" _
(ByVal hconnect As Long, ByVal lpszUrl As String, ByVal lpszHeaders As Long, _
ByVal dwHdrLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetReadFileVBA Lib "wininet.dll" Alias "InternetReadFile" _
(ByVal hFile As Long, ByVal lpBuffer As String, _
ByVal dwNbBytesToRead As Long, ByRef lpdwNbBytesRead As Long) As Long
Private Declare Function InternetQueryDataAvailable Lib "wininet.dll" _
(ByVal hFile As Long, ByRef lpdwNumberOfBytesAvailable As Long, _
ByVal dwFlags As Long, dwContext As Long) As Long
' hFile : retourné par InternetOpenUrl ou FtpOpenFile ou HttpOpenRequest ou GopherOpenFile
' ---------------------------------------------------------------------------------
' Lecture fichier http par blocs et HTTPrequest
' - InternetOpen
' - InternetConnect
' - HttpOpenRequest
' - HttpSendRequest
'
' Paramètre 1 : URL http
' Paramètre 2 : Cible (chemin complet + Nom)
' ---------------------------------------------------------------------------------
Sub Lecture_fichierHTTP(httpURL As String, strCible As String)
' Internet Handles for Internet Session, Internet Connection, HTTP Request
Dim hInternetSess As Long, hIConnect As Long, httpReq As Long
' File Handle (Windows)
Dim hFile As Long
' Read/Writte buffer
Const BUFSIZE = 1024
Dim buffer As String, ErrBuffer As String, ErrNum As Long
Dim qryBuffer As String, qryBufLength As Long, qryIndex As Long
'
Dim BytesAvailable As Long, strSvrResponseCode As String
Dim BytesToRead As Long, BytesRead As Long
Dim BytesToWrite As Long, BytesWritten As Long
Dim strServer As String, strObjPathName As String
Dim RemoteFileSize As Long, localFileSize As Long
Dim oRegEx As RegExp, oMatches As MatchCollection, oMatch As Match
'
Dim RetVal As Long, p As Long, strErrMsg As String, strHttpErrDesc As String
' HTTP/1.1 http URL Syntax
' http_URL = "http:" "//" host [ ":" port ] [ abs_path ]
' scheme = "http"
' abs_path = "/" + .....
' Coupe l'URL en deux parties : Serveur et chemin absolu
Set oRegEx = New VBScript_RegExp_55.RegExp
oRegEx.Pattern = "^(?:http://){0,1}([^/]*)(/.*)$"
Set oMatches = oRegEx.Execute(httpURL)
If oMatches.Count = 1 Then
Set oMatch = oMatches.Item(0)
strServer = oMatch.SubMatches(0) & vbNullChar
strObjPathName = oMatch.SubMatches(1) & vbNullChar
Else
MsgBox "L'URL http n'est pas correcte"
Exit Sub
End If
On Error GoTo ERRH
'Ouvre session internet - OK si valeur renvoyé<>0
hInternetSess = InternetOpen("MonAppli", 0, vbNullString, vbNullString, 0)
If hInternetSess = 0 Then err.Raise 1001
'Connection au serveur HTTP - OK si valeur renvoyé<>0
hIConnect = InternetConnect(hInternetSess, strServer, _
INTERNET_DEFAULT_HTTP_PORT, vbNullChar, vbNullChar, INTERNET_SERVICE_HTTP, 0, 0)
If hIConnect = 0 Then err.Raise 1002
' Prépare requête HTTP - OK si valeur renvoyé <>0
httpReq = HttpOpenRequest(hIConnect, "GET" & vbNullChar, strObjPathName, _
"HTTP/1.1" & vbNullChar, 0, _
0, 0, 0)
If httpReq = 0 Then err.Raise 1003
' Envoie Requête HTTP - OK valeur renvoyée 1
RetVal = HttpSendRequest2(httpReq, 0, 0, 0, 0)
If RetVal <> 1 Then err.Raise 1004
' Examine Code envoyé par serveur
' "2xx"=succedd ("200"=OK), "3xx" = Redirection, 4xx Client Error ("404" = Non trouvé)
qryBuffer = String(512, vbNullChar): qryBufLength = 512
' fonction HttpQueryInfo - OK si valeur renvoyé 1
RetVal = HttpQueryInfo(httpReq, HTTP_QUERY_STATUS_CODE, qryBuffer, qryBufLength, qryIndex)
If RetVal = 1 Then
strSvrResponseCode = Left(qryBuffer, 3)
Else
err.Raise 1005
End If
' Erreur si serveur répond avec 4xx ou 5xx
If strSvrResponseCode Like "[4,5]??" Then err.Raise 1006
' Nbre d'octets à prêts à lire. (<>Total à lire)
'RetVal = InternetQueryDataAvailable(httpReq, BytesAvailable, 0, 0)
' Ouvre fichier local
hFile = CreateFile(strCible & vbNullChar, GENERIC_WRITE, 0, 0, _
CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
If hFile = 0 Then err.Raise 1007
localFileSize = 0
BytesToRead = BUFSIZE
' Boucle sur fichier distant
buffer = String(BUFSIZE + 1, vbNullChar)
Do
RetVal = InternetReadFileVBA(httpReq, buffer, BytesToRead, BytesRead) 'VarPtr(BytesRead)
If RetVal = 1 Then
BytesToWrite = BytesRead
Else
err.Raise 1031
End If
If BytesToWrite > 0 Then
RetVal = WriteFile(hFile, buffer, BytesToWrite, BytesWritten, 0)
localFileSize = localFileSize + BytesWritten
End If
Loop While BytesRead > 0
END_SUB1:
CloseHandle (hFile) 'Ferme Fichier Local
END_SUB2:
InternetCloseHandle httpReq 'Ferme handle requête HTTP _
'(fichier distant dans cette fonction)
InternetCloseHandle hIConnect 'Ferme Connection Internet
InternetCloseHandle hInternetSess 'Ferme Session internet
Exit Sub
ERRH:
ErrNum = err.LastDllError
' Liste des codes erreurs wininet.dll:
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wininet/wininet/wininet_errors.asp
Select Case err.Number
Case 1001
MsgBox "Echec ouverture session internet. Code erreur " & CStr(ErrNum)
Case 1002
MsgBox "Echec création connexion au serveur " & strServer & ". Code erreur " & CStr(ErrNum)
Case 1003
MsgBox "Echec préparation requête HTTP. Code erreur " & CStr(ErrNum)
Case 1004
MsgBox "Echec requête HTTP. Code erreur " & CStr(ErrNum) & ". Vérifiez l'URL"
Case 1005
MsgBox "Echec requête HTTP QUERY_STATUS_CODE. Code erreur " & CStr(ErrNum) & ". Vérifiez l'URL"
Case 1006
' Le serveur a renvoyé un code 4xx ou 5xx
Select Case CInt(strSvrResponseCode)
Case 400: strHttpErrDesc = "Bad Request"
Case 401: strHttpErrDesc = "Unauthorized"
Case 402: strHttpErrDesc = "Payment Required"
Case 403: strHttpErrDesc = "Forbidden"
Case 404: strHttpErrDesc = "Not Found"
Case 405: strHttpErrDesc = "Method Not Allowed"
Case 406: strHttpErrDesc = "Not Acceptable"
Case 407: strHttpErrDesc = "Proxy Authentication Required"
Case 408: strHttpErrDesc = "Request Time-out"
Case 409: strHttpErrDesc = "Conflict"
Case 410: strHttpErrDesc = "Gone"
Case 411: strHttpErrDesc = "Length Required"
Case 412: strHttpErrDesc = "Precondition Failed"
Case 413: strHttpErrDesc = "Request Entity Too Large"
Case 414: strHttpErrDesc = "Request-URI Too Large"
Case 415: strHttpErrDesc = "Unsupported Media Type"
Case 500: strHttpErrDesc = "Internal Server Error"
Case 501: strHttpErrDesc = "Not Implemented"
Case 502: strHttpErrDesc = "Bad Gateway"
Case 503: strHttpErrDesc = "Service Unavailable"
Case 504: strHttpErrDesc = "Gateway Time-out"
Case 505: strHttpErrDesc = "HTTP Version not supported"
End Select
strErrMsg = "Le serveur HTTP a répondu ave le code suivant : " & strSvrResponseCode
If strHttpErrDesc <> "" Then
strErrMsg = strErrMsg & " - " & strHttpErrDesc & vbCrLf
Else
strErrMsg = strErrMsg & " (code non répertorié)" & vbCrLf
End If
strErrMsg = strErrMsg & "URL : " & httpURL
MsgBox strErrMsg, , "Erreur HTTP"
Case 1007
MsgBox "Echec création fichier " & strCible
Case 1031
MsgBox "Erreur N° " & CStr(ErrNum) & " , pendant lecture HTTP" & strCible
Case Else
strErrMsg = "Erreur N° " & CStr(err.Number) & " - " & err.Description
MsgBox strErrMsg
End Select
Resume END_SUB1
End Sub
Private Function lirefichier(Nom As String) As String
On Error GoTo err
'Declare le systeme de fichier
Dim FSO As New Scripting.FileSystemObject
'Declare le fichier texte
Dim FichText As Scripting.TextStream
'Ouvre le fichier en lecture
Set FichText = FSO.OpenTextFile(Nom, ForReading)
'Lit le fichier
lirefichier = FichText.ReadAll
'libere les variable
GoTo fin
err:
MsgBox "Impossible de lire le fichier", vbCritical, _
"Erreur de lecture"
fin:
Set FichText = Nothing
Set FSO = Nothing
End Function
Private Function EntreBalises(strtext As String, strbaliseBegin As String, strbaliseEnd As String) As String
Dim result As String
result = strtext
If InStr(1, result, strbaliseBegin) > 0 Then
result = Mid(result, InStr(1, result, strbaliseBegin) + Len(strbaliseBegin))
If InStr(1, result, strbaliseEnd) > 0 Then
result = Left(result, InStr(1, result, strbaliseEnd) - 1)
End If
End If
EntreBalises = result
End Function
Sub piou()
Lecture_fichierHTTP "http://www.developpez.net/forums/", "C:\temp\test.txt"
MsgBox EntreBalises(lirefichier("C:\temp\test.txt"), "<title>", "</title")
End Sub |
Récupérer titre page web
a ce sujet:
Répondre avec citation
Partager