|
-
Mar 16th, 2024, 11:15 PM
#1
Thread Starter
Fanatic Member
used HttpSendRequestEx Upload data to the web page in sections
// InternetOpen ---:InternetConnect----HttpOpenRequest----InternetSetOption -HttpAddRequestHeaders---HttpSendRequestEx
Code:
Option Explicit
Event HttpError(Status As String)
Event HttpOpen(Status As String)
Event HttpSend(SendNum As Long, _
Total As Long, _
Status As String, _
Ncancel As Boolean) '???????,??,??????
Event HttpComplete(????? As String, ??cookie As String, ????() As Byte)
Private Declare Sub Sleep Lib "Kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal length As Long)
Private Declare Function InternetOpenUrl _
Lib "wininet.dll" _
Alias "InternetOpenUrlA" (ByVal hOpen As Long, _
ByVal sUrl As String, _
ByVal sHeaders As String, _
ByVal lLength As Long, _
ByVal lFlags As Long, _
ByVal lContext 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 pub_lngInternetSession 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 InternetReadFile _
Lib "wininet.dll" (ByVal hFile As Long, _
sBuffer As Any, _
ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetWriteFile _
Lib "wininet.dll" (ByVal hFile As Long, _
buffer As Any, _
ByVal lNumBytesToWrite As Long, _
dwNumberOfBytesWritten As Long) As Integer
Private Declare Function InternetSetCookie _
Lib "wininet.dll" _
Alias "InternetSetCookieA" (ByVal lpszUrlName As String, _
ByVal lpszCookieName As String, _
ByVal lpszCookieData As String) As Boolean
Private Declare Function InternetGetCookie _
Lib "wininet.dll" _
Alias "InternetGetCookieA" (ByVal lpszUrlName As String, _
ByVal lpszCookieName As String, _
ByVal lpszCookieData As String, _
lpdwSize As Long) As Boolean
Private Declare Function InternetCloseHandle _
Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Type INTERNET_BUFFERS
dwStructSize As Long ' used for API versioning. Set to sizeof(INTERNET_BUFFERS)
Next As Long ' INTERNET_BUFFERS chain of buffers
lpcszHeader As Long ' pointer to headers (may be NULL)
dwHeadersLength As Long ' length of headers if not NULL
dwHeadersTotal As Long ' size of headers if not enough buffer
lpvBuffer As Long ' pointer to data buffer (may be NULL)
dwBufferLength As Long ' length of data buffer if not NULL
dwBufferTotal As Long ' total size of chunk, or content-length if not chunked
dwOffsetLow As Long ' used for read-ranges (only used in HttpSendRequest2)
dwOffsetHigh As Long
End Type
Private InternetBUFFERS As INTERNET_BUFFERS
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 HttpSendRequest _
Lib "wininet.dll" _
Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, _
ByVal sHeaders As String, _
ByVal lHeadersLength As Long, _
sOptional As Any, _
ByVal lOptionalLength As Long) As Integer
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 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 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 InternetQueryOption _
Lib "wininet.dll" _
Alias "InternetQueryOptionA" (ByVal hInternet As Long, _
ByVal lOption As Long, _
ByRef sBuffer As Any, _
ByRef lBufferLength As Long) As Integer
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_OPEN_TYPE_PROXY = 3
Const INTERNET_INVALID_PORT_NUMBER = 0
Const INTERNET_DEFAULT_HTTP_PORT = 80
Const INTERNET_SERVICE_HTTP = 3
Const SECURITY_FLAG_IGNORE_UNKNOWN_CA = &H100
Const INTERNET_FLAG_ASYNC = &H10000000 ' this request is asynchronous (where supported)
Const INTERNET_FLAG_TRANSFER_BINARY = &H2
Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000 ' don't write this item to the cache
Const INTERNET_FLAG_DONT_CACHE = INTERNET_FLAG_NO_CACHE_WRITE
Const INTERNET_FLAG_SECURE = &H800000 ' use PCT/SSL if applicable (HTTP)
Const INTERNET_FLAG_KEEP_CONNECTION = &H400000 ' use keep-alive semantics
Const INTERNET_FLAG_MULTIPART = &H200000
Const INTERNET_FLAG_NO_AUTO_REDIRECT = &H200000 ' don't handle redirections automatically
Const INTERNET_FLAG_READ_PREFETCH = &H100000 ' do background read prefetch
Const INTERNET_FLAG_RELOAD = &H80000000 ' ==Brings the data across the wire even if it locally cached.
Const INTERNET_FLAG_NO_COOKIES = &H80000 ' no automatic cookie handling
Const INTERNET_FLAG_NO_AUTH = &H40000 ' no automatic authentication handling
Const INTERNET_FLAG_CACHE_IF_NET_FAIL = &H10000 ' return cache file if net request fails
Const INTERNET_STATUS_REQUEST_COMPLETE = 100 '????????
Const INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Const INTERNET_DEFAULT_HTTPS_PORT = 443
Const INTERNET_DEFAULT_SOCKS_PORT = 1080
Const INTERNET_OPTION_CONNECT_TIMEOUT = 2
Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6
Const INTERNET_OPTION_SEND_TIMEOUT = 5
Const INTERNET_OPTION_USERNAME = 28
Const INTERNET_OPTION_PASSWORD = 29
Const INTERNET_OPTION_PROXY_USERNAME = 43
Const INTERNET_OPTION_PROXY_PASSWORD = 44
Const HTTP_QUERY_CONTENT_LENGTH = 5 '???? ??? ??? ????.
Const HTTP_QUERY_STATUS_CODE = 19 '?? ?? ??? ????? ????.
Const HTTP_QUERY_LAST_MODIFIED = 11
Const HTTP_QUERY_PRAGMA = 17
Const HTTP_QUERY_VERSION = 18
Const HTTP_QUERY_FORWARDED = 30
Const HTTP_QUERY_SERVER = 37
Const HTTP_QUERY_USER_AGENT = 39
Const HTTP_QUERY_SET_COOKIE = 43
Const HTTP_QUERY_REQUEST_METHOD = 45
Const HTTP_STATUS_DENIED = 401
Const HTTP_STATUS_PROXY_AUTH_REQ = 407
Const HTTP_QUERY_STATUS_TEXT = 20
Const HTTP_QUERY_RAW_HEADERS = 21
Const HTTP_QUERY_RAW_HEADERS_CRLF = 22
Const HTTP_QUERY_CONTENT_TYPE = 1
Const WININET_API_FLAG_ASYNC = 1 '// force async operation
Const WININET_API_FLAG_SYNC = 4 '// force sync operation
Const WININET_API_FLAG_USE_CONTEXT = 8 '// use value supplied in dwContext (even if 0)
Const HSR_ASYNC = WININET_API_FLAG_ASYNC '// force async
Const HSR_SYNC = WININET_API_FLAG_SYNC '// force sync
Const INTERNET_FLAG_IGNORE_CERT_DATE_INVALID = &H2000
Const INTERNET_OPTION_SECURITY_FLAGS = 31
Const INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H1000
Const HSR_USE_CONTEXT = WININET_API_FLAG_USE_CONTEXT '// use dwContext value
Const HSR_INITIATE = 8 '// iterative operation (completed by HttpEndRequest)
Const HSR_DOWNLOAD = 16 '// download to file
Const HSR_CHUNKED = 32 '// operation is send of chunked data
Const INTERNET_OPTION_VERSION = 40
Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000
Const HTTP_ADDREQ_FLAG_ADD = &H20000000
Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
Const HTTP_QUERY_FLAG_NUMBER = &H20000000
Private Declare Function InternetFindNextFile _
Lib "wininet.dll" _
Alias "InternetFindNextFileA" (ByVal hFind As Long, _
lpvFindData As WIN32_FIND_DATA) As Long
Private Const FTP_TRANSFER_TYPE_BINARY As Long = &H2 '0x00000002
Private Const INTERNET_SERVICE_FTP = 1
Private Declare Function InternetSetOption _
Lib "wininet.dll" _
Alias "InternetSetOptionA" (ByVal hInternet As Long, _
ByVal lOption As Long, _
ByRef sBuffer As Any, _
ByVal lBufferLength As Long) As Integer
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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 Integer
Private Declare Function InternetSetOptionStr _
Lib "wininet.dll" _
Alias "InternetSetOptionA" (ByVal hInternet As Long, _
ByVal lOption As Long, _
ByVal sBuffer As String, _
ByVal lBufferLength As Long) As Integer
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type
Dim bProcess As Boolean
Dim stStart As Single
Enum UploadSpeedEnum
UploadLowSpeed = -1 ' 50? ??? Sleep(1)? ?? / CPU???(H) 50%
UploadNormalSpeed = 0 '100? ??? Sleep(1)? ?? / CPU???(H) 70%
UploadHighSpeed = 1 '150? ??? Sleep(1)? ?? / CPU???(H) 80%
End Enum
Private m_LonLenPostArray As Long
Private m_StrReturnCookie As String
Private m_StrReturnHeads As String
Private m_StrStatus As String
Private m_BytReturnArray() As Byte
Public Function ReturnArray() As Byte
ReturnArray = m_BytReturnArray()
End Function
Public Property Get ReturnCookie() As String '?????cookei
ReturnCookie = m_StrReturnCookie
End Property
Public Property Get LenPostArray() As Long '??post?????,????
LenPostArray = m_LonLenPostArray
End Property
-
Mar 16th, 2024, 11:16 PM
#2
Thread Starter
Fanatic Member
Re: used HttpSendRequestEx Upload data to the web page in sections
Code:
Private Function HTTPUpload(lngServer As Long, strUrl As String, sHeader As String, refer As String, cookies As String, PostDate() As Byte, Optional ByVal SetUploadSpeed As UploadSpeedEnum = UploadNormalSpeed, Optional BUFFER_SIZE As Long = 1024, Optional ???? As Long = 5000, Optional ????????? As Boolean = False, Optional ????Cookie?IE As Boolean = False, Optional ??? As String = vbNullString, Optional ?? As String = vbNullString)
Dim hFile As Long
Dim bBuffer() As Byte
Dim dwSecFlag As Long
Dim SecFlag As Long
Dim Ret As Long, nRet As Long, i As Long, nFilesize As Long
nFilesize = UBound(PostDate) + 1 '??PostDate????
m_LonLenPostArray = nFilesize '????
If ????????? = True Then
SecFlag = INTERNET_FLAG_NO_COOKIES
Else
SecFlag = INTERNET_FLAG_NO_AUTO_REDIRECT Or INTERNET_FLAG_NO_COOKIES
End If
hFile = HttpOpenRequest(lngServer, "POST", GetUrlObject(strUrl), "HTTP/1.1", vbNullString, 0, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_MULTIPART Or INTERNET_FLAG_NO_CACHE_WRITE Or SecFlag, 0)
If hFile = 0 Then
HTTPUpload = -3: m_StrStatus = "????????"
RaiseEvent HttpError(m_StrStatus)
Exit Function
Else
m_StrStatus = "??????,???????"
End If
Dim iRetVal As Integer, tmpHead As String
If sHeader <> "" Then
iRetVal = HttpAddRequestHeaders(hFile, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
tmpHead = sHeader + vbCrLf
sHeader = ""
If iRetVal Then m_StrStatus = "???????!"
End If
If refer <> "" Then
iRetVal = HttpAddRequestHeaders(hFile, refer, Len(refer), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
tmpHead = tmpHead + refer + vbCrLf
If iRetVal Then m_StrStatus = "????refer??!"
End If
If cookies <> "" Then
iRetVal = HttpAddRequestHeaders(hFile, cookies, Len(cookies), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
tmpHead = tmpHead + cookies + vbCrLf
If iRetVal Then m_StrStatus = "??cookies??!"
End If
Dim dwTimeOut As Long
dwTimeOut = ???? ' time out is set to 7 minutes
iRetVal = InternetSetOption(hFile, INTERNET_OPTION_CONNECT_TIMEOUT, dwTimeOut, 4)
iRetVal = InternetSetOption(hFile, INTERNET_OPTION_RECEIVE_TIMEOUT, dwTimeOut, 4)
iRetVal = InternetSetOption(hFile, INTERNET_OPTION_SEND_TIMEOUT, dwTimeOut, 4)
sHeader = "Content-Length: " + CStr(nFilesize) + vbCrLf
iRetVal = HttpAddRequestHeaders(hFile, sHeader, Len(sHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
sHeader = tmpHead + sHeader
If iRetVal Then m_StrStatus = "????????!"
Dim hHttpSendRequestEx As Long, hHttpEndRequest As Long
Dim iInternetWriteFile As Integer
Dim BufferIn As INTERNET_BUFFERS
BufferIn.dwStructSize = Len(InternetBUFFERS) '== sizeof(InternetBUFFERS) ' // Must be set or error will occur
BufferIn.dwHeadersLength = Len(sHeader)
BufferIn.dwBufferTotal = nFilesize ' // This is the only member used other than dwStructSize
Debug.Print sHeader
Resend:
iRetVal = HttpSendRequestEx(hFile, BufferIn, 0, WININET_API_FLAG_SYNC Or HSR_INITIATE, 0) '(hFile, BufferIn, 0, 8, 0)
Debug.Print iRetVal
If (iRetVal <> 1) And (Err.LastDllError = 12045) Then
m_StrStatus = "???????"
dwSecFlag = SECURITY_FLAG_IGNORE_UNKNOWN_CA
iRetVal = InternetSetOption(hFile, INTERNET_OPTION_SECURITY_FLAGS, dwSecFlag, 4)
GoTo Resend
End If
If iRetVal Then
If iRetVal Then m_StrStatus = "????????!"
Dim dwStatus As Long, dwStatusSize As Long
dwStatusSize = Len(dwStatus)
HttpQueryInfo hFile, HTTP_QUERY_FLAG_NUMBER Or HTTP_QUERY_STATUS_CODE, dwStatus, dwStatusSize, 0
Select Case dwStatus
Case HTTP_STATUS_PROXY_AUTH_REQ
m_StrStatus = "??????,?????????!"
If ??? <> "" Then
iRetVal = InternetSetOptionStr(hFile, INTERNET_OPTION_PROXY_USERNAME, ???, Len(???) + 1)
iRetVal = InternetSetOptionStr(hFile, INTERNET_OPTION_PROXY_PASSWORD, ??, Len(??) + 1)
GoTo Resend
End If
Case HTTP_STATUS_DENIED
m_StrStatus = "??????,???????!"
If ??? <> "" Then
iRetVal = InternetSetOptionStr(hFile, INTERNET_OPTION_USERNAME, ???, Len(???) + 1)
iRetVal = InternetSetOptionStr(hFile, INTERNET_OPTION_PASSWORD, ??, Len(??) + 1)
GoTo Resend
End If
End Select
bProcess = True
Dim SleepTime As Integer
Dim SleepCount As Integer
Select Case SetUploadSpeed '// 'Set Delay Value
Case UploadLowSpeed: SleepCount = 50
If (nFilesize / 1024) <= SleepCount Then SleepCount = 5 ' /File LowSize : ReSet
Case UploadNormalSpeed: SleepCount = 160
If (nFilesize / 1024) <= SleepCount Then SleepCount = 8 ' /File LowSize : ReSet
Case UploadHighSpeed: SleepCount = 200
If (nFilesize / 1024) <= SleepCount Then SleepCount = 10 ' /File LowSize : ReSet
End Select
ReDim bBuffer(BUFFER_SIZE - 1)
Dim bCancel As Boolean, x As Long
For i = 1 To nFilesize \ BUFFER_SIZE '????.buffer-size
If bCancel = True Then
bProcess = False
InternetCloseHandle hFile
HTTPUpload = -7
m_StrStatus = "????"
RaiseEvent HttpError(m_StrStatus)
Exit Function 'Exit Function
End If
Call CopyMemory(ByVal VarPtr(bBuffer(0)), ByVal VarPtr(PostDate(x)), BUFFER_SIZE) '??????
iInternetWriteFile = InternetWriteFile(hFile, bBuffer(0), BUFFER_SIZE, nRet) 'Debug.Print nRet
x = BUFFER_SIZE * i
RaiseEvent HttpSend(BUFFER_SIZE * i, nFilesize, m_StrStatus, bCancel) '??????
If SleepTime = SleepCount Then
SleepTime = 0: DoEvents 'Delay
Sleep 1
Else
SleepTime = SleepTime + 1
If SleepTime = CInt((SleepCount / 2)) Then DoEvents
End If
Next i
If (nFilesize Mod BUFFER_SIZE) <> 0 Then
ReDim bBuffer((nFilesize Mod BUFFER_SIZE) - 1)
CopyMemory bBuffer(0), PostDate(x), (nFilesize Mod BUFFER_SIZE) ' Get #FNum, , bBuffer ': Debug.Print (bBuffer)
iInternetWriteFile = InternetWriteFile(hFile, bBuffer(0), UBound(bBuffer) + 1, nRet) 'Debug.Print nRet
End If
DoEvents: DoEvents
hHttpEndRequest = HttpEndRequest(hFile, 0, WININET_API_FLAG_SYNC Or HSR_INITIATE, 0)
If hHttpEndRequest = 1 Then
Dim lblContentType As String, lblContentLength As String, lblLastModified As String
Dim lblVersion As String, lblStatusCode As String, lblRawHeaders As String, lblStatusText As String
Dim txtRequestHeaders As String
Dim lblForwarded As String, lblServer As String, lblRequestMethod As String, lblPragma As String, lblUserAgent As String, lblRequestMethod2 As String
GetQueryInfo hFile, lblContentType, HTTP_QUERY_CONTENT_TYPE
GetQueryInfo hFile, lblContentLength, HTTP_QUERY_CONTENT_LENGTH
GetQueryInfo hFile, lblLastModified, HTTP_QUERY_LAST_MODIFIED
GetQueryInfo hFile, lblVersion, HTTP_QUERY_VERSION
GetQueryInfo hFile, lblStatusCode, HTTP_QUERY_STATUS_CODE '????
GetQueryInfo hFile, lblStatusText, HTTP_QUERY_STATUS_TEXT
GetQueryInfo hFile, lblRawHeaders, HTTP_QUERY_RAW_HEADERS
GetQueryInfo hFile, m_StrReturnHeads, HTTP_QUERY_RAW_HEADERS_CRLF '?????
GetQueryInfo hFile, lblForwarded, HTTP_QUERY_FORWARDED
GetQueryInfo hFile, lblServer, HTTP_QUERY_SERVER
GetQueryInfo hFile, lblRequestMethod, HTTP_QUERY_REQUEST_METHOD
GetQueryInfo hFile, lblPragma, HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_PRAGMA
GetQueryInfo hFile, txtRequestHeaders, HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_RAW_HEADERS_CRLF
GetQueryInfo hFile, lblUserAgent, HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_USER_AGENT
GetQueryInfo hFile, lblRequestMethod2, HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_REQUEST_METHOD
m_StrStatus = "OK~?????~~~"
If InStr(m_StrReturnHeads, "Set-Cookie: ") > 0 Then
m_StrReturnCookie = ??Cookie(m_StrReturnHeads)
m_StrStatus = "??cookies"
If ????Cookie?IE = True Then
Dim sCookieVal As String * 256
InternetSetCookie "http://" + CheckUrl(strUrl), "cookie:", m_StrReturnCookie
InternetGetCookie "http://" + CheckUrl(strUrl), "cookie:", sCookieVal, 255
m_StrStatus = "??cookies?IE"
Debug.Print Left$(sCookieVal, InStr(sCookieVal, Chr$(0)) - 1)
End If
End If
Dim lBytesRead As Long, lRead As Long
Const CHUNK_SIZE = &H2000& '?????????
ReDim bBuffer(0 To CHUNK_SIZE)
Do
InternetReadFile hFile, bBuffer(0), CHUNK_SIZE, lRead
If lRead Then '?????
ReDim Preserve m_BytReturnArray(0 To lBytesRead + lRead - 1&)
CopyMemory m_BytReturnArray(lBytesRead), bBuffer(0), lRead
lBytesRead = lBytesRead + lRead
Dim b As New strWeb
If lRead < CHUNK_SIZE Then
Exit Do
End If
Else
Exit Do
End If
Loop
RaiseEvent HttpComplete(m_StrReturnHeads, m_StrReturnCookie, m_BytReturnArray)
Else
m_StrStatus = "??????"
RaiseEvent HttpError(m_StrStatus)
End If
End If
InternetCloseHandle hFile
HTTPUpload = 0
bProcess = False
End Function
Public Sub Upload_API_HTTP(strUrl As String, port As Integer, sHeader As String, refer As String, cookies As String, PostDate() As Byte, Optional ByVal SetUploadSpeed As UploadSpeedEnum = UploadNormalSpeed, Optional BUFFER_SIZE As Long = 1024, Optional ???? As Long = 5000, Optional ????????? As Boolean = False, Optional ???? As String = vbNullString, Optional ????Cookie?IE As Boolean = False, Optional ??? As String = vbNullString, Optional ?? As String = vbNullString)
Dim HttpSession As Long, HttpServer As Long
Const User_Agent = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
If port = 0 Then port = INTERNET_DEFAULT_HTTP_PORT '80??
HttpSession = InternetOpen(User_Agent, INTERNET_OPEN_TYPE_PRECONFIG, ????, vbNullString, 0) ' "", "", INTERNET_FLAG_NO_CACHE_WRITE)
If CBool(HttpSession) Then
m_StrStatus = "??http??"
InternetQueryOption HttpSession, INTERNET_OPTION_VERSION, vbNullString, 0
HttpServer = InternetConnect(HttpSession, CheckUrl(strUrl), port, ???, ??, INTERNET_SERVICE_HTTP, 0, 0)
If HttpServer > 0 Then
m_StrStatus = "???????"
RaiseEvent HttpOpen(m_StrStatus)
Call HTTPUpload(HttpServer, strUrl, sHeader, "", "", PostDate(), SetUploadSpeed, BUFFER_SIZE, ????, ?????????, ????Cookie?IE, ???, ??)
InternetCloseHandle HttpServer
End If
InternetCloseHandle HttpSession
End If
End Sub
Private Function CheckUrl(ByVal txtURL As String) As String
If Right$(txtURL, 1) = "/" Then
txtURL = Mid$(txtURL, 1, Len(txtURL) - 1)
End If
txtURL = Replace(txtURL, "http://", "")
If Len(txtURL) = 0 Then txtURL = "www.microsoft.com"
Dim posSlash As Long
posSlash = InStr(txtURL, "/")
If InStr(txtURL, "/") <> 0 Then
CheckUrl = Left(txtURL, InStr(txtURL, "/") - 1)
Else
CheckUrl = txtURL
End If
End Function
Private Function GetUrlObject(ByVal txtURL As String) As String
If Right$(txtURL, 1) = "/" Then
txtURL = Mid$(txtURL, 1, Len(txtURL) - 1)
End If
txtURL = Replace(txtURL, "http://", "")
If InStr(txtURL, "/") <> 0 Then
GetUrlObject = Right(txtURL, Len(txtURL) - InStr(txtURL, "/") + 1)
Else
GetUrlObject = ""
End If
End Function
Private Function GetQueryInfo(ByVal hHttpRequest As Long, _
ByRef lblContentType As String, _
ByVal iInfoLevel As Long) As Boolean
Dim sBuffer As String * 1024
Dim lBufferLength As Long
lBufferLength = Len(sBuffer)
GetQueryInfo = CBool(HttpQueryInfo(hHttpRequest, iInfoLevel, ByVal sBuffer, lBufferLength, 0))
lblContentType = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)
End Function
Private Function ??Cookie(Str$) '??Cookie,??.getAllResponseHeaders ???????cookie
Dim cookie$, a&, b&, c$, d&, e&, f$
a = InStr(Str, "Set-Cookie: ")
If a = 0 Then
??Cookie = ""
Else
b = InStr(a, Str, ";")
If b = 0 Then
??Cookie = Mid(Str, a + Len("Set-Cookie: "))
Else
c = Mid(Str, a + 12, b - a - 11)
cookie = c
Do
d = InStr(b, Str, "Set-Cookie: ")
If d = 0 Then Exit Do
e = InStr(d, Str, ";")
f = Mid(Str, d + 12, e - d - 11)
b = e
cookie = cookie & f
Loop
??Cookie = cookie
End If
End If
End Function
Function ReadBinaryFile(FileName)
Const adTypeBinary = 1
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Open
BinaryStream.LoadFromFile FileName
ReadBinaryFile = BinaryStream.Read
End Function
Function ReadStrToBinary(heads As String, FileName As String, ends As String)
Const adTypeBinary = 1
Const adTypeText = 2
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = 1
BinaryStream.Open
BinaryStream.Write StringToBytes(heads, "gbk")
BinaryStream.Write ReadBinaryFile(FileName)
BinaryStream.Write StringToBytes(ends, "gbk")
BinaryStream.Position = 2
ReadStrToBinary = BinaryStream.Read
End Function
Public Function StringToBytes(ByVal strData, Optional ByVal strCharset As String = "GBK")
Dim objFile
Set objFile = CreateObject("ADODB.Stream")
objFile.Type = 2
objFile.Charset = strCharset
objFile.Open
objFile.WriteText strData
objFile.Position = 0
objFile.Type = 1
If UCase(strCharset) = "UNICODE" Then
objFile.Position = 2 'delete UNICODE BOM
ElseIf UCase(strCharset) = "UTF-8" Then
objFile.Position = 3 'delete UTF-8 BOM
End If
StringToBytes = objFile.Read(-1)
objFile.Close
Set objFile = Nothing
End Function
Public Function AddForm(key As String, value As String) As String
Dim temp As String
temp = temp & key & "=" & """" & value & """"
AddForm = temp
End Function
Public Function GetBoundary(n As Integer) As String
Dim key As String
Dim n1, i1 As Integer
key = "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890abcdefghigklmnopkrstuvwsyz"
Randomize (Timer)
For i1 = 1 To n
n1 = Int(Rnd * Len(key)) + 1
GetBoundary = GetBoundary & Mid(key, n1, 1)
Next
End Function
-
Mar 16th, 2024, 11:19 PM
#3
Thread Starter
Fanatic Member
Re: used HttpSendRequestEx Upload data to the web page in sections
Code:
Private Sub Command1_Click()
On Error GoTo herr:
'Upload_FTP_or_HTTP
Dim a() As Byte, heads As String, boundaryL As String, jpgs As String
Dim Fdata As String, Edata As String '?????????
If Text7 = "" Then MsgBox "????????????": GoTo herr
Picture1.Picture = LoadPicture(Text7)
jpgs = Mid(Text7, InStrRev(Text7, "\") + 1)
Text4 = ""
Set http = New HttpSendArray
boundaryL = http.GetBoundary(Len("WebKitFormBoundaryPR4M1jdedSpjp93T"))
heads = Replace(Text1, "{boundary}", boundaryL)
Fdata = "------" & boundaryL & vbCrLf & "Content-Disposition: form-data; "
Fdata = Fdata + http.AddForm("name", "MAX_FILE_SIZE") + vbCrLf + vbCrLf
Fdata = Fdata + "200000000" + vbCrLf + "------" & boundaryL & vbCrLf & "Content-Disposition: form-data; "
Fdata = Fdata + http.AddForm("name", "uploadimg") & "; "
Fdata = Fdata + http.AddForm("filename", jpgs) & vbCrLf & "Content-Type: image/png" & vbCrLf + vbCrLf
Edata = vbCrLf & Replace(Text3, "{boundary}", boundaryL)
a = http.ReadStrToBinary(Fdata, Text7, Edata)
Command1.Enabled = False: Command2.Enabled = False
Call http.Upload_API_HTTP("http://www.xxxx/upload.php", 80, heads, "", "", a, UploadLowSpeed, 5000)
herr:
Exit Sub
End Sub
Private Sub http_HttpComplete(????? As String, ??cookie As String, ????() As Byte)
Text4 = Text4 & Status & "?????" & CStr(100) & "%" & vbNewLine & String(18, "?") & vbNewLine
Text4 = Text4 & ??cookie & vbNewLine & String(18, "?") & vbNewLine
If IsArrayNull(????()) = False Then
Text4 = Text4 & b.Utf8??????(????, cpUTF8) & vbNewLine & String(18, "?") & vbNewLine
End If
Set http = Nothing
If Command1.Enabled = False Then Command1.Enabled = True
If Command2.Enabled = False Then Command2.Enabled = True
End Sub
Private Sub http_HttpOpen(Status As String)
Text4 = Status
End Sub
Private Sub http_HttpSend(SendNum As Long, Total As Long, Status As String, Ncancel As Boolean)
Text4 = Text4 & Status & "?????" & Format(CStr(SendNum / Total), "0.00%") & vbNewLine & String(18, "?") & vbNewLine
End Sub
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote