'=============================================================读源码=========
Public Function duyuanma(WebUrl, charset, Optional chaoshi As Double = 8) '=duyuanma（网址)
duyuanma = BytesToBstr(GetBody(WebUrl, chaoshi), charset)
End Function
'XMLHTTP 获取函数
'2010-9-30 增加超时参数 可精确到0.1秒 单位秒
'2010-9-25 修正获取失败问题
'2011.1.9 增加清理缓存代码
Public Function GetBody(WebUrl, Optional chaoshi As Double = 8)
On Error Resume Next
Dim xmlHttp
'Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
'xmlHttp.SetProxy 2, "58.52.112.138:4326" '设置代理IP访问 上面必须用XML2 -代理网站 太阳代理
If Form1.Check1.Value = 1 Then
xmlHttp.SetProxy 2, Form1.Text6.Text '设置代理IP访问 上面必须用XML2 -代理网站 太阳代理
End If
xmlHttp.setTimeouts 2000, 2000, 2000, 2000
xmlHttp.Open "GET", WebUrl, True
xmlHttp.setRequestHeader "If-Modified-Since", "0"
If Form1.Option1.Value = True Then
xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0+(compatible;+Baiduspider-render/2.0;++http://www.baidu.com/search/spider.html)"
ElseIf Form1.Option2.Value = True Then
xmlHttp.setRequestHeader "User-Agent", "Sogou+web+spider/4.0(+http://www.sogou.com/docs/help/webmasters.htm#07)"
ElseIf Form1.Option3.Value = True Then
xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0+(Windows+NT+6.1;+Win64;+x64)+AppleWebKit/537.36+(KHTML,+like+Gecko)+Chrome/69.0.3497.81+YisouSpider/5.0+Safari/537.36"
Else
xmlHttp.setRequestHeader "User-Agent", "Mozilla/5.0+(Linux;+Android+6.0.1;+Nexus+6P+Build/MMB29P)+AppleWebKit/537.36+(KHTML,+like+Gecko)+Chrome/47.0.2526.83+Mobile+Safari/537.36;+360Spider"
End If
xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlHttp.send
Dim t0
t0 = Timer
While xmlHttp.ReadyState <> 4 And Timer - t0 < chaoshi
DoEvents
Wend
If Timer - t0 > chaoshi Then GetBody = "获取内容超时2222"
If xmlHttp.ReadyState = 4 Then
If xmlHttp.Status = 200 Then
GetBody = xmlHttp.responsebody
Else
GetBody = "bb" & xmlHttp.Status
End If
Else
GetBody = "AA" & xmlHttp.Status '默认是空
End If
Dim sError
If Err.Number <> 0 Then
sError = Err.Number
Err.Clear
Else
sError = "cc"
End If
Set xmlHttp = Nothing
End Function
'远程获取网页编码格式转换
Public Function BytesToBstr(body, charset)
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
On Error Resume Next
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.charset = charset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function
'=============================================================读源码=========