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.
373.
374.
375.
376.
377.
378.
379.
380.
381.
382.
383.
384.
385.
386.
387.
388.
389.
390.
391.
392.
393.
394.
395.
396.
397.
398.
399.
400.
401.
402.
403.
404.
405.
406.
407.
408.
409.
410.
411.
412.
413.
414.
415.
416.
417.
418.
419.
420.
Option Explicit
Private Const INTERNET_AUTODIAL_FORCE_ONLINE As Long = 1
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_DEFAULT_HTTP_PORT As Long = 80
Private Const INTERNET_SERVICE_HTTP As Long = 3
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const HTTP_ADDREQ_FLAG_REPLACE As Long = &H80000000
Private Const HTTP_ADDREQ_FLAG_ADD As Long = &H20000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Declare Function HttpSendRequestEx Lib "wininet.dll" Alias "HttpSendRequestExA" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
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 hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lModifiers As Long) As Long
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal sOptional As String, ByVal lOptionalLength As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Long
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Private Declare Function HttpEndRequest Lib "wininet.dll" Alias "HttpEndRequestA" (ByVal hHttpRequest As Long, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function InternetWriteFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Const HTTP_QUERY_CONTENT_TYPE = 1
Private Const HTTP_QUERY_CONTENT_LENGTH = 5
Private Const HTTP_QUERY_EXPIRES = 10
Private Const HTTP_QUERY_LAST_MODIFIED = 11
Private Const HTTP_QUERY_PRAGMA = 17
Private Const HTTP_QUERY_VERSION = 18
Private Const HTTP_QUERY_STATUS_CODE = 19
Private Const HTTP_QUERY_STATUS_TEXT = 20
Private Const HTTP_QUERY_RAW_HEADERS = 21
Private Const HTTP_QUERY_RAW_HEADERS_CRLF = 22
Private Const HTTP_QUERY_FORWARDED = 30
Private Const HTTP_QUERY_SERVER = 37
Private Const HTTP_QUERY_USER_AGENT = 39
Private Const HTTP_QUERY_SET_COOKIE = 43
Private Const HTTP_QUERY_REQUEST_METHOD = 45
Private Const HTTP_STATUS_DENIED = 401
Private Const HTTP_STATUS_PROXY_AUTH_REQ = 407
Private Const HSR_INITIATE = &H8
'Private Declare Function HttpSendRequestEx Lib "wininet.dll" Alias "HttpSendRequestExA" (ByVal hHttpRequest As Long, lpBuffersIn As INTERNET_BUFFERS, ByVal lpBuffersOut As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Type INTERNET_BUFFERS
dwStructSize As Long
Next As Long
lpcszHeader As Long
dwHeadersLength As Long
dwHeadersTotal As Long
lpvBuffer As Long
dwBufferLength As Long
dwBufferTotal As Long
dwOffsetLow As Long
dwOffsetHigh As Long
End Type
Function TranslateErrorCode(ByVal lErrorCode As Long) As String
Select Case lErrorCode
Case 12001: TranslateErrorCode = "No more handles could be generated at this Time "
Case 12002: TranslateErrorCode = "The request has timed out."
Case 12003: TranslateErrorCode = "An extended error was returned from the server."
Case 12004: TranslateErrorCode = "An internal error has occurred."
Case 12005: TranslateErrorCode = "The URL is invalid."
Case 12006: TranslateErrorCode = "The URL scheme could not be recognized, or is not supported."
Case 12007: TranslateErrorCode = "The server name could not be resolved."
Case 12008: TranslateErrorCode = "The requested protocol could not be located."
Case 12009: TranslateErrorCode = "A request to InternetQueryOption or InternetSetOption specified an invalid option value."
Case 12010: TranslateErrorCode = "The length of an option supplied to InternetQueryOption or InternetSetOption is incorrect for the type of option specified."
Case 12011: TranslateErrorCode = "The request option can not be set, only queried. "
Case 12012: TranslateErrorCode = "The Win32 Internet support is being shutdown or unloaded."
Case 12013: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied user name is incorrect."
Case 12014: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied password is incorrect. "
Case 12015: TranslateErrorCode = "The request to connect to and login to an FTP server failed."
Case 12016: TranslateErrorCode = "The requested operation is invalid. "
Case 12017: TranslateErrorCode = "The operation was canceled, usually because the handle on which the request was operating was closed before the operation completed."
Case 12018: TranslateErrorCode = "The type of handle supplied is incorrect for this operation."
Case 12019: TranslateErrorCode = "The requested operation can not be carried out because the handle supplied is not in the correct state."
Case 12020: TranslateErrorCode = "The request can not be made via a proxy."
Case 12021: TranslateErrorCode = "A required registry value could not be located. "
Case 12022: TranslateErrorCode = "A required registry value was located but is an incorrect type or has an invalid value."
Case 12023: TranslateErrorCode = "Direct network access cannot be made at this time. "
Case 12024: TranslateErrorCode = "An asynchronous request could not be made because a zero context value was supplied."
Case 12025: TranslateErrorCode = "An asynchronous request could not be made because a callback function has not been set."
Case 12026: TranslateErrorCode = "The required operation could not be completed because one or more requests are pending."
Case 12027: TranslateErrorCode = "The format of the request is invalid."
Case 12028: TranslateErrorCode = "The requested item could not be located."
Case 12029: TranslateErrorCode = "The attempt to connect to the server failed."
Case 12030: TranslateErrorCode = "The connection with the server has been terminated."
Case 12031: TranslateErrorCode = "The connection with the server has been reset."
Case 12036: TranslateErrorCode = "The request failed because the handle already exists."
Case Else: TranslateErrorCode = "Error details not available."
End Select
End Function
Private Function getQueryOption(info As String, hHttpOpenRequest As Long) As String
Dim sBuffer As String * 1024
Dim lBufferLength As Long
Dim intRes As Integer
sBuffer = vbNullString
lBufferLength = Len(sBuffer)
intRes = HttpQueryInfo(hHttpOpenRequest, info, ByVal sBuffer, lBufferLength, 0)
If intRes > 0 Then
getQueryOption = sBuffer
Else
getQueryOption = vbNullString
End If
End Function
Private Function HttpPostFromFile(ByVal FileNameToSend As String, _
ByRef ReturnString As String, _
ByRef result As HTTPTransactionResult) As Boolean
On Local Error GoTo error_handler
Dim hInternetOpen As Long
Dim hInternetConnect As Long
Dim hHttpOpenRequest As Long
Dim bRet As Boolean
Dim lret As Long
Dim iret As Integer
Dim filenumb As Integer
Dim macchina As String
Dim doc As String
Dim BufferIn As INTERNET_BUFFERS
Dim abBin() As Byte
Dim sbinfile As String
Dim nbinfile As Integer
Dim dwpostsize As Long
Dim n As Long
Dim letti As Long
Dim pbuffer As String
Dim MyOffset As Long
Dim chunks As Long
Dim BytesRemain As Long
Dim ChunkLen As Long
Dim bDoLoop As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sHeader As String
Dim sBoundary As String
'Definitions
ChunkLen = 2048
' On Error GoTo error_handler
hInternetOpen = 0
hInternetConnect = 0
hHttpOpenRequest = 0
result.strRETURN_ERROR = vbNullString
result.intRETURN_ERROR = 0
' macchina = URLToMachineName(documento)
' doc = URLToPathFileName(documento)
hInternetOpen = InternetOpen("", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
Label1(0).Caption = hInternetOpen
If hInternetOpen = 0 Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'internetopen ok
hInternetConnect = InternetConnect(hInternetOpen, "www.***.ru", INTERNET_DEFAULT_HTTP_PORT, "", "", INTERNET_SERVICE_HTTP, 0, 0)
Label1(1).Caption = hInternetConnect
If hInternetConnect = 0 Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'internetConnect Ok
'hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", "/http_in.php", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "POST", "/http_in.php", "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
Label1(2).Caption = hHttpOpenRequest
If hHttpOpenRequest = 0 Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'HTTPopenrequest OK
sBoundary = "3fbd04f5-b1ed-4060-99b9-fca7ff59c113"
sHeader = "Content-Type: multipart/form-data; boundary=" & sBoundary & vbCrLf
'rslt2 = HttpAddRequestHeaders(hRequest, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
' Label1(4).Caption = rslt2
'--- post data
sbinfile = FileNameToSend
' Text2.Text = "--" & sBoundary & vbCrLf & _
"Content-Disposition: multipart/form-data; name=""upfile""; filename=""" & Mid$(sbinfile, InStrRev(sbinfile, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
"SOD" & vbCrLf & "--" & sBoundary & "--"
' sHeader = "Content-Type: application/x-octet-stream" & vbCrLf
iret = HttpAddRequestHeaders(hHttpOpenRequest, _
sHeader, _
Len(sHeader), _
HTTP_ADDREQ_FLAG_REPLACE Or _
HTTP_ADDREQ_FLAG_ADD)
Label1(3).Caption = iret
If iret = 0 Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'HttpAddRequestHeaders ok
sbinfile = FileNameToSend
nbinfile = FreeFile
Open sbinfile For Binary Access Read Lock Write As #nbinfile
'
ReDim abBin(ChunkLen)
dwpostsize = LOF(nbinfile)
' Close #nbinfile
BufferIn.dwStructSize = 40 ' Must be set or error will occur
BufferIn.Next = 0
BufferIn.lpcszHeader = 0
BufferIn.dwHeadersLength = 0
BufferIn.dwHeadersTotal = 0
BufferIn.lpvBuffer = 0
BufferIn.dwBufferLength = 0
BufferIn.dwBufferTotal = dwpostsize 'This is the only member used other than dwStructSize
BufferIn.dwOffsetLow = 0
BufferIn.dwOffsetHigh = 0
'HSR_INITIATE try with the second last param.
bRet = HttpSendRequestEx(hHttpOpenRequest, BufferIn, 0, 0, 0)
Label1(4).Caption = bRet
If (bRet = False) Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'SendRequestEx ok
' nbinfile = FreeFile
' Open sbinfile For Binary Access Read Lock Write As #nbinfile
chunks = dwpostsize \ ChunkLen
BytesRemain = dwpostsize - (chunks * ChunkLen)
MyOffset = 1
n = 0
bRet = True
Dim RealChunkLen As Long
RealChunkLen = 0
While (n < chunks) And (bRet = True)
Get #nbinfile, MyOffset, abBin
pbuffer = StrConv(abBin, vbUnicode)
'pbuffer = "--" & sBoundary & vbCrLf & _
"Content-Disposition: multipart/form-data; name=""upfile""; filename=""" & Mid$(sbinfile, InStrRev(sbinfile, "\") + 1) & """" & vbCrLf & _
"Content-Type: application/octet-stream" & vbCrLf & vbCrLf & _
StrConv(abBin, vbUnicode) & vbCrLf & "--" & sBoundary & "--"
bRet = InternetWriteFile(hHttpOpenRequest, _
pbuffer, _
ChunkLen, _
letti)
n = n + 1
Text1.Text = Text1.Text & "send " & n
MyOffset = 1 + (n * ChunkLen)
Wend
Label1(5).Caption = bRet
If bRet = False Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'all internetwritefile (- the last) ok
ReDim abBin(BytesRemain)
Get #nbinfile, MyOffset, abBin
pbuffer = StrConv(abBin, vbUnicode) ' & vbCrLf & "--" & sBoundary & "--"
'pbuffer = pbuffer & "--AaBbCcDd00--"
bRet = InternetWriteFile(hHttpOpenRequest, _
pbuffer, _
BytesRemain, _
letti)
Close #nbinfile
Label1(6).Caption = bRet
If bRet = False Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'the last internetwritefile ok
Dim param As Long
param = 0
'HSR_INITIATE penultimo
lret = HttpEndRequest(hHttpOpenRequest, 0, 0, 0)
Label1(7).Caption = lret
If lret = 0 Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'HttpEndRequest ok
result.HTTP_QUERY_CONTENT_TYPE = getQueryOption(HTTP_QUERY_CONTENT_TYPE, hHttpOpenRequest)
result.HTTP_QUERY_CONTENT_LENGTH = getQueryOption(HTTP_QUERY_CONTENT_LENGTH, hHttpOpenRequest)
result.HTTP_QUERY_LAST_MODIFIED = getQueryOption(HTTP_QUERY_LAST_MODIFIED, hHttpOpenRequest)
result.HTTP_QUERY_PRAGMA = getQueryOption(HTTP_QUERY_PRAGMA, hHttpOpenRequest)
result.HTTP_QUERY_EXPIRES = getQueryOption(HTTP_QUERY_EXPIRES, hHttpOpenRequest)
result.HTTP_QUERY_VERSION = getQueryOption(HTTP_QUERY_VERSION, hHttpOpenRequest)
result.HTTP_QUERY_STATUS_CODE = getQueryOption(HTTP_QUERY_STATUS_CODE, hHttpOpenRequest)
result.HTTP_QUERY_STATUS_TEXT = getQueryOption(HTTP_QUERY_STATUS_TEXT, hHttpOpenRequest)
result.HTTP_QUERY_RAW_HEADERS = getQueryOption(HTTP_QUERY_RAW_HEADERS, hHttpOpenRequest)
result.HTTP_QUERY_RAW_HEADERS_CRLF = getQueryOption(HTTP_QUERY_RAW_HEADERS_CRLF, hHttpOpenRequest)
result.HTTP_QUERY_FORWARDED = getQueryOption(HTTP_QUERY_FORWARDED, hHttpOpenRequest)
result.HTTP_QUERY_SERVER = getQueryOption(HTTP_QUERY_SERVER, hHttpOpenRequest)
result.HTTP_QUERY_USER_AGENT = getQueryOption(HTTP_QUERY_USER_AGENT, hHttpOpenRequest)
result.HTTP_QUERY_SET_COOKIE = getQueryOption(HTTP_QUERY_SET_COOKIE, hHttpOpenRequest)
result.HTTP_QUERY_REQUEST_METHOD = getQueryOption(HTTP_QUERY_REQUEST_METHOD, hHttpOpenRequest)
If (Val(result.HTTP_QUERY_STATUS_CODE) <> 200) Then
result.intRETURN_ERROR = Val(result.HTTP_QUERY_STATUS_CODE)
result.strRETURN_ERROR = result.HTTP_QUERY_STATUS_TEXT
HttpPostFromFile = False
Else 'Not 200
bDoLoop = True
While bDoLoop = True And bRet = True
sReadBuffer = vbNullString
bRet = InternetReadFile(hHttpOpenRequest, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
ReturnString = ReturnString & Left(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
Label1(8).Caption = bRet
If (bRet = False) Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
Else 'InternetReadFile Ok
result.intRETURN_ERROR = 0
result.strRETURN_ERROR = vbNullString
HttpPostFromFile = True
End If
End If ' Not 200
End If 'HttpEndRequest
End If 'last internetwritefile
End If 'all the InternetWriteFile (- the last)
End If 'SendRequestEx
bRet = InternetCloseHandle(hHttpOpenRequest)
If (bRet = False) Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
End If
End If 'HttpAddRequestHeaders ok
End If 'HTTPopenrequest
bRet = InternetCloseHandle(hInternetConnect)
If (bRet = False) Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
End If
End If 'InternetConnect
bRet = InternetCloseHandle(hInternetOpen)
If (bRet = False) Then
result.intRETURN_ERROR = Err.LastDllError
result.strRETURN_ERROR = TranslateErrorCode(CLng(result.intRETURN_ERROR))
HttpPostFromFile = False
End If
End If 'InternetOpen
Exit Function
error_handler:
result.strRETURN_ERROR = Err.Description
result.intRETURN_ERROR = Err.Number
HttpPostFromFile = False
Exit Function
End Function
Private Sub Form_Load()
Dim rslt As HTTPTransactionResult
Me.Caption = HttpPostFromFile(App.Path & "\123456.txt", Text1.Text, rslt)
End Sub
