·上一篇:JS insertAdjacentHTML 兼容IE与FF的写法
·下一篇:VB WinInet Post/Get 提交模块代码
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
评论内容只代表网友观点,与本站立场无关!
评论摘要(共 0 条,得分 0 分,平均 0 分)
查看完整评论