Results 1 to 3 of 3

Thread: used HttpSendRequestEx Upload data to the web page in sections

  1. #1

    Thread Starter
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    683

    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

  2. #2

    Thread Starter
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    683

    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

  3. #3

    Thread Starter
    Fanatic Member
    Join Date
    Aug 2016
    Posts
    683

    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
  •  



Click Here to Expand Forum to Full Width