Question

VB 获取网页源码 获取指定区域内容

http://php.weather.sina.com.cn/search.php?city=北京 加载这个网页 获取<ul class="detail">
<li><span class="fs_30 tpte">15℃</span> <span class="fs_14">体感</span> <span class="fs_24 tpte">15℃</span></li>
<li>晴</li>
<li>无持续风向 ≤3级</li>
</ul>
获取15℃ 体感 15℃ 晴 无持续风向 ≤3级 并在LABEL控件显示

Answer 1

Private Sub Form_Load()
url = "http://php.weather.sina.com.cn/search.php?city=北京"
code = GetYM(url, "gb2312")
a = InStr(code, "fs_30 tpte")
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
a = InStr(a + 1, code, ">")
b = InStr(a + 1, code, "<")
s = s & Mid(code, a + 1, b - a - 1) & " "
Label1.Caption = s
End Sub
'2011.8.17
'获取源码函数
'WebUrl-网页地址
'charset-编码 常见的有UTF-8 GB2312
'chaoshi-设置超时时间 单位秒
Function GetYM(WebUrl, charset, Optional chaoshi As Double = 5)
GetYM = BytesToBstr(GetBody(WebUrl, chaoshi), charset)
End Function
'XMLHTTP 获取函数
'2010-9-30 增加超时参数 可精确到0.1秒 单位秒
'2010-9-25 修正获取失败问题
'2011.1.9 增加清理缓存代码
Function GetBody(WebUrl, Optional chaoshi As Double = 5)
On Error Resume Next
Dim xmlHttp
'Set xmlHttp=createobject("Msxml2.XMLHTTP.4.0")
Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
'Set xmlHttp = CreateObject("MSXML2.ServerXMLHTTP")
'xmlHttp.setTimeouts 2000, 2000, 2000, 2000
xmlHttp.Open "GET", WebUrl, True
xmlHttp.setRequestHeader "If-Modified-Since", "0"
xmlHttp.send
Dim t0
t0 = Timer
While xmlHttp.ReadyState <> 4 And Timer - t0 < chaoshi
'MsgBox xmlHttp.readystate
DoEvents
Wend
If Timer - t0 > chaoshi Then GetBody = "获取内容超时"
If xmlHttp.ReadyState = 4 Then
'if xmlHttp.status=200 then
GetBody = xmlHttp.responsebody
'end if
Else
GetBody = ""
End If
Dim sError
If Err.Number <> 0 Then
sError = Err.Number
Err.Clear
Else
sError = ""
End If
Set xmlHttp = Nothing
End Function
'远程获取网页编码格式转换
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

Answer 2

易语言轻松实现