'=======GET方式获取网页源代码================
Function GetCode(Url As String, CodeBase As String)
'第一个参数是地址,第二个参数是设置编码方式(GB2312或UTF-8).
Dim xmlHTTP1
Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")
xmlHTTP1.Open "get", Url, True
xmlHTTP1.send
While xmlHTTP1.readyState <> 4
DoEvents
Wend
GetCode = xmlHTTP1.responseBody
If CStr(GetCode) <> "" Then GetCode = BytesToBstr(GetCode, CodeBase)
Set xmlHTTP1 = Nothing
End Function
Function BytesToBstr(strBody, ByVal CodeBase As String)
Dim ObjStream
Set ObjStream = CreateObject("Adodb.Stream")
With ObjStream
.Type = 1
.Mode = 3
.Open
.write strBody
.Position = 0
.Type = 2
.Charset = CodeBase
BytesToBstr = .ReadText
.Close
End With
Set ObjStream = Nothing
End Function
'=======POST方式获取网页源代码================
'先引用Microsoft XML, V3.0
Function PostData(url As String, strData As String)
Dim xml As New XMLHTTP
Dim str1 As String
'url = "http://www.0575.com/"
'strData = "a=1&b=1"
xml.Open "POST", url, False
xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xml.send strData
If xml.Status = 200 Then
str1 = StrConv(xml.responseBody, vbUnicode) '返回的内容
End If
PostData = str1
End Function
'==========新方法获取网页源码===============
'需要Inet
'新获取网页源码方法Inet
Function getHtmlFrom(u)
Dim BinBuff() As Byte
Dim StrUrl As String
StrUrl = u
BinBuff = Inet1.OpenURL(StrUrl, icByteArray)
getHtmlFrom = Utf8ToUnicode(BinBuff)
End Function
'下面这是个模块
'utf- 8转换UNICODE代码
Option Explicit
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8 = 65001
Function Utf8ToUnicode(ByRef Utf() As Byte) As String
Dim lRet As Long
Dim lLength As Long
Dim lBufferSize As Long
lLength = UBound(Utf) - LBound(Utf) + 1
If lLength <= 0 Then Exit Function
lBufferSize = lLength * 2
Utf8ToUnicode = String$(lBufferSize, Chr(0))
lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize)
If lRet <> 0 Then
Utf8ToUnicode = Left(Utf8ToUnicode, lRet)
Else
Utf8ToUnicode = ""
End If
End Function