爱华网'网页编码转换Public Function BytesToBstr(Bytes, Optional Charset AsString) Dim objstream AsObject Set objstream =CreateObject("ADODB.Stream") With objstream .Type = 1 .Mode = 3 .Open .Write Bytes .Position = 0 .Type = 2 .Charset = Charset BytesToBstr = .ReadText .Close End WithEnd Function
Private Sub Command1_Click() '下载文件 CallWriteFile(HttpDownload("http://www.baidu.com/img/baidu_jgylogo3.gif"),"c:123.gif") '获取网页源码 Debug.PrintBytesToBstr(HttpDownload("http://www.soso.com/"), "GB2312")End Sub
'Mode--------------------------Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0Private Const INTERNET_OPEN_TYPE_DIRECT = 1Private Const INTERNET_OPEN_TYPE_PROXY = 3Private Const scUserAgent = "Microsoft Internet Explorer6.0"Private Const INTERNET_FLAG_RELOAD = &H80000000Private Declare Function InternetOpen Lib "wininet.dll" Alias"InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long,ByVal sProxyName As String, ByVal sProxyBypass As String, ByVallFlags As Long) As LongPrivate Declare Function InternetOpenUrl Lib "wininet.dll"Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl AsString, ByVal sHeaders As String, ByVal lLength As Long, ByVallFlags As Long, ByVal lContext As Long) As LongPrivate Declare Function InternetReadFileByte Lib"wininet.dll" Alias "InternetReadFile" (ByVal hFile As Long, ByRefsBuffer As Byte, ByVal lNumBytesToRead As Long, lNumberOfBytesReadAs Long) As IntegerPrivate Declare Function InternetCloseHandle Lib "wininet.dll"(ByVal hInet As Long) As IntegerPrivate Declare Function HttpQueryInfo Lib "wininet.dll" Alias"HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel AsLong, ByVal sBuffer As Any, ByRef lBufferLength As Long, ByReflIndex As Long) As IntegerConst HTTP_QUERY_CONTENT_LENGTH = 5Const HTTP_QUERY_FLAG_NUMBER = &H20000000Private Declare Function InternetReadFile Lib "wininet.dll"(ByVal hFile As Long, ByVal sBuffer As String, ByVallNumBytesToRead As Long, lNumberOfBytesRead As Long) AsIntegerPublic Declare Sub CopyMemory Lib "kernel32" Alias"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length AsLong)Private Function IsNullBytes(ByRef sBytes() As Byte) AsBoolean On Error ResumeNext Dim N As Long N =UBound(sBytes()) If Err Then IsNullBytes = True End IfEnd FunctionPublic Function HttpDownload(ByVal sUrl As String, OptionalByVal lNewBufferSize As Long = -1) As Byte() Dim bBuffer() AsByte Dim lBufferSize AsLong Dim retBytes() AsByte Dim hOpen As Long Dim hOpenUrl AsLong Dim hQuery As Long Dim lFileSize AsLong Dim sQuery AsString Dim i As Long Dim lBufferNumber AsLong Dim lRealFileLen AsLong Dim bDoLoop AsBoolean Dim lNumberOfBytesReadAs Long Dim BSize As Long On Error GoToFindErr If lNewBufferSize = -1Then lBufferSize = 2048 Else lBufferSize = lNewBufferSize If lBufferSize < 1024 Then lBufferSize =1024 End If ReDimbBuffer(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 <> -1Then bDoLoop = True lBufferNumber = Fix(lFileSize /lBufferSize) If lFileSize Mod lBufferSize <> 0 ThenlBufferNumber = 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) EndIf IfIsNullBytes(retBytes) Then ReDimretBytes(UBound(bBuffer)) retBytes = bBuffer Else BSize =UBound(retBytes) ReDim Preserve retBytes(BSize+ UBound(bBuffer) + 1) CallCopyMemory(retBytes(BSize + 1), bBuffer(0), UBound(bBuffer) +1) EndIf lRealFileLen = lRealFileLen + lNumberOfBytesRead If NotCBool(lNumberOfBytesRead) Then Exit For Next i Else i = 0 Do i = i +1 bDoLoop =InternetReadFileByte(hOpenUrl, bBuffer(0), lBufferSize,lNumberOfBytesRead) IflBufferSize <> lNumberOfBytesRead Then If lNumberOfBytesRead = 0 OrbDoLoop = 0 Then Exit Do Else lBufferSize = lNumberOfBytesRead ReDim Preserve bBuffer(lBufferSize - 1) AsByte End If EndIf IfIsNullBytes(retBytes) Then ReDimretBytes(UBound(bBuffer)) retBytes = bBuffer Else BSize =UBound(retBytes) ReDim Preserve retBytes(BSize+ UBound(bBuffer) + 1) CallCopyMemory(retBytes(BSize + 1), bBuffer(0), UBound(bBuffer) +1) EndIf lRealFileLen = lRealFileLen + lNumberOfBytesRead Loop End If If hOpenUrl <> 0Then InternetCloseHandle (hOpenUrl) If hOpen <> 0 ThenInternetCloseHandle (hOpen) HttpDownload =retBytes Exit FunctionFindErr: HttpDownload =VBA.vbNullCharEnd Function
