用户登录  |  用户注册
首 页源码下载网络学院最新源码源码排行屏蔽广告
当前位置:新兴网络 > 网络学院 > 编程开发 > Visual Basic

VB WinInet Post/Get 提交模块代码

减小字体 增大字体 作者:LinHaibo  来源:新兴网络  发布时间:2011-10-09 01:07:19
'调用示例
Debug.Print WinInetGet("http://127.0.0.1/index.html")

Debug.Print WinInetPost("http://127.0.0.1/index.php", "UserName=admin")

'上面两个函数都是返回byte数组,如果出现乱码可以通过以下这个函数安指定编码转换一下就可以了。
'比如:
Debug.Print BytesToBstr(WinInetPost("http://127.0.0.1/index.php", "UserName=admin"), "UTF-8")
Public Function BytesToBstr(Bytes, Optional Charset As String)
    Dim objstream As Object
    Set objstream = CreateObject("ADODB.Stream")
    With objstream
        .Type = 1
        .Mode = 3
        .Open
        .Write Bytes
        .Position = 0
        .Type = 2
        .Charset = Charset
        BytesToBstr = .ReadText
        .Close
    End With
End Function
VBScript code复制代码
Option Explicit
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const scUserAgent = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)"
Private Const INTERNET_FLAG_RELOAD = &H80000000
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 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 InternetReadFileByte Lib "wininet.dll" Alias "InternetReadFile" (ByVal hFile As Long, ByRef sBuffer As Byte, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByVal sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
Const HTTP_QUERY_CONTENT_LENGTH = 5
Const HTTP_QUERY_FLAG_NUMBER = &H20000000
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal lpszServerName As String, ByVal nProxyWebPort As Integer, ByVal lpszUsername As String, ByVal lpszPassword As String, ByVal dwService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" (ByVal hInternetSession As Long, ByVal lpszVerb As String, ByVal lpszObjectName As String, ByVal lpszVersion As String, ByVal lpszReferer As String, ByVal lpszAcceptTypes As Long, ByVal dwFlags As Long, ByVal dwContext 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 Boolean
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 Function IsNullBytes(ByRef sBytes() As Byte) As Boolean
    On Error Resume Next
    Dim N As Long
    N = UBound(sBytes())
    If Err Then
        IsNullBytes = True
    End If
End Function

'Get
Public Function WinInetGet(ByVal sURL As String, Optional ByVal lNewBufferSize As Long = 2048) As Byte()
    Dim bBuffer() As Byte
    Dim lBufferSize As Long
    Dim retBytes() As Byte
    Dim hOpen As Long
    Dim hOpenUrl As Long
    Dim hQuery As Long
    Dim lFileSize As Long
    Dim sQuery As String
    Dim i As Long
    Dim lBufferNumber As Long
    Dim lRealFileLen As Long
    Dim bDoLoop As Boolean
    Dim lNumberOfBytesRead As Long
    Dim BSize As Long
    On Error GoTo FindErr
   
    If lNewBufferSize <> 2048 Then
        lBufferSize = lNewBufferSize
        If lBufferSize < 1024 Then lBufferSize = 1024
    Else
        lBufferSize = lNewBufferSize
    End If
    ReDim bBuffer(lBufferSize - 1) As Byte
   
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    hOpenUrl = InternetOpenUrl(hOpen, sURL, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
   
    sQuery = String$(1024, " ")
    hQuery = HttpQueryInfo(hOpenUrl, HTTP_QUERY_CONTENT_LENGTH, ByVal sQuery, Len(sQuery), 0)
   
    If hQuery Then
        lFileSize = CLng(Trim(sQuery))
    Else
        lFileSize = -1
    End If
   
    If lFileSize <> -1 Then
        bDoLoop = True
        lBufferNumber = Fix(lFileSize / lBufferSize)
        If lFileSize Mod lBufferSize <> 0 Then lBufferNumber = lBufferNumber + 1
        lRealFileLen = 0
        For i = 1 To lBufferNumber
            If i < lBufferNumber Then
                bDoLoop = InternetReadFileByte(hOpenUrl, bBuffer(0), lBufferSize, lNumberOfBytesRead)
            Else
                lBufferSize = lFileSize - lBufferSize * (i - 1)
                ReDim bBuffer(lBufferSize - 1) As Byte
                bDoLoop = InternetReadFileByte(hOpenUrl, bBuffer(0), lBufferSize, lNumberOfBytesRead)
            End If
            If IsNullBytes(retBytes) Then
                ReDim retBytes(UBound(bBuffer))
                retBytes = bBuffer
            Else
                BSize = UBound(retBytes)
                ReDim Preserve retBytes(BSize + UBound(bBuffer) + 1)
                Call CopyMemory(retBytes(BSize + 1), bBuffer(0), UBound(bBuffer) + 1)
            End If
            lRealFileLen = lRealFileLen + lNumberOfBytesRead
            If Not CBool(lNumberOfBytesRead) Then Exit For
            VBA.DoEvents
        Next i
    Else
        i = 0
        Do
            i = i + 1
            bDoLoop = InternetReadFileByte(hOpenUrl, bBuffer(0), lBufferSize, lNumberOfBytesRead)
            If lBufferSize <> lNumberOfBytesRead Then
                If lNumberOfBytesRead = 0 Or bDoLoop = 0 Then
                    Exit Do
                Else
                    lBufferSize = lNumberOfBytesRead
                    ReDim Preserve bBuffer(lBufferSize - 1) As Byte
                End If
            End If
            If IsNullBytes(retBytes) Then
                ReDim retBytes(UBound(bBuffer))
                retBytes = bBuffer
            Else
                BSize = UBound(retBytes)
                ReDim Preserve retBytes(BSize + UBound(bBuffer) + 1)
                Call CopyMemory(retBytes(BSize + 1), bBuffer(0), UBound(bBuffer) + 1)
            End If
           
            lRealFileLen = lRealFileLen + lNumberOfBytesRead
            VBA.DoEvents
        Loop
    End If
   
    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
   
    WinInetGet = retBytes
    Exit Function
FindErr:
    WinInetGet = VBA.vbNullChar
End Function

'Post
Public Function WinInetPost(sURL As String, PostData As String) As Byte()
    On Error GoTo Over
    Dim IntOpen As Long, IntConnect As Long, XHttpOpenRequest As Long, BRet As Boolean, ScriptName As String, lRealFileLen As Long
    If LCase(Left(sURL, 7)) = "http://" Then sURL = Right(sURL, Len(sURL) - 7)
    If InStr(sURL, "/") Then
        ScriptName = Right(sURL, Len(sURL) - InStr(sURL, "/") + 1)
        sURL = Left(sURL, InStr(sURL, "/") - 1)
    Else
        ScriptName = "/"
    End If
   
    lRealFileLen = 0
    IntOpen = 0
    IntConnect = 0
    XHttpOpenRequest = 0
    Const INTERNET_OPEN_TYPE_PRECONFIG = 0
    IntOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
    If IntOpen <> 0 Then
        Const INTERNET_SERVICE_HTTP = 3
        Const INTERNET_DEFAULT_HTTP_WebPort = 80
        IntConnect = InternetConnect(IntOpen, sURL, INTERNET_DEFAULT_HTTP_WebPort, vbNullString, "HTTP/1.0", INTERNET_SERVICE_HTTP, 0, 0)
        If IntConnect <> 0 Then
            Const INTERNET_FLAG_RELOAD = &H80000000
            XHttpOpenRequest = HttpOpenRequest(IntConnect, "POST", ScriptName, "HTTP/1.0", vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
            If XHttpOpenRequest <> 0 Then
                Dim HttpHeader As String
                Const HTTP_ADDREQ_FLAG_ADD = &H20000000
                Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
                HttpHeader = "Content-Type: application/x-www-form-urlencoded" & vbCrLf
                BRet = HttpAddRequestHeaders(XHttpOpenRequest, HttpHeader, Len(HttpHeader), HTTP_ADDREQ_FLAG_REPLACE Or HTTP_ADDREQ_FLAG_ADD)
                BRet = HttpSendRequest(XHttpOpenRequest, vbNullString, 0, PostData, Len(PostData))
                Dim TheLoop As Boolean, RBuffer As String * 2048, ByteNumberRead As Long, IBuffer As String
                Dim bBuffer() As Byte, retBytes() As Byte, lBufferSize As Long, BSize As Long, i As Long, lNumberOfBytesRead As Long
                lBufferSize = 2048
                ReDim bBuffer(lBufferSize - 1) As Byte
                i = 0
                Do
                    i = i + 1
                    TheLoop = InternetReadFileByte(XHttpOpenRequest, bBuffer(0), lBufferSize, lNumberOfBytesRead)
                    If lBufferSize <> lNumberOfBytesRead Then
                        If lNumberOfBytesRead = 0 Or TheLoop = 0 Then
                            Exit Do
                        Else
                            lBufferSize = lNumberOfBytesRead
                            ReDim Preserve bBuffer(lBufferSize - 1) As Byte
                        End If
                    End If
                    If IsNullBytes(retBytes) Then
                        ReDim retBytes(UBound(bBuffer))
                        retBytes = bBuffer
                    Else
                        BSize = UBound(retBytes)
                        ReDim Preserve retBytes(BSize + UBound(bBuffer) + 1)
                        Call CopyMemory(retBytes(BSize + 1), bBuffer(0), UBound(bBuffer) + 1)
                    End If
                   
                    lRealFileLen = lRealFileLen + lNumberOfBytesRead
                    VBA.DoEvents
                Loop
               
                WinInetPost = retBytes
                BRet = InternetCloseHandle(XHttpOpenRequest)
            End If
            BRet = InternetCloseHandle(IntConnect)
        End If
        BRet = InternetCloseHandle(IntOpen)
    End If
    Exit Function
Over:
    WinInetPost = VBA.vbNullChar
End Function
 

Tags:WinInet Post Get VB

作者:LinHaibo
  • 好的评价 如果您觉得此文章好,就请您
      100%(5)
  • 差的评价 如果您觉得此文章差,就请您
      0%(0)

网络学院评论评论内容只代表网友观点,与本站立场无关!

   评论摘要(共 0 条,得分 0 分,平均 0 分) 查看完整评论