VB Wininet实现文件下载与网页获取函数

'下面是在Form窗体中的调用示例代码。

VBScript code复制代码

'写入文件
Private Sub WriteFile(ByteArray() As Byte, Path As String)
    Open Path For Binary As #1
    Put #1, , ByteArray()
    Close #1
End Sub

'网页编码转换
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

Private Sub Form_Load()
   
    '下载文件
    Call WriteFile(HttpDownload("http://www.baidu.com/img/baidu_jgylogo3.gif"), "c:\123.gif")
   
    '获取网页源码
    Debug.Print BytesToBstr(HttpDownload("http://www.soso.com/"), "GB2312")
End Sub

下面代码是在模块中的。

VBScript code复制代码

Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const scUserAgent = "Microsoft Internet Explorer 6.0"
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 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
Public Function HttpDownload(ByVal sUrl As String, Optional ByVal lNewBufferSize As Long = -1) 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 = -1 Then
        lBufferSize = 2048
    Else
        lBufferSize = lNewBufferSize
        If lBufferSize < 1024 Then lBufferSize = 1024
    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
        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
        Loop
    End If
   
    If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
    If hOpen <> 0 Then InternetCloseHandle (hOpen)
   
    HttpDownload = retBytes
    Exit Function
FindErr:
    HttpDownload = VBA.vbNullChar
End Function