楼主
xmyjk |
Q：如图，像图片所示的网站一样模糊查询城市名，并获得该城市的天气预报？
A:
原理简要分析：
运用textbox的change事件，只要在文本框输入文字，就调用查询程序名程序，向网址发包。
取回城市名的数据后，再将listbox显示出来，并将城市数据进行显示。
当鼠标点击listbox后，将所点击的Listbox的城市数据进行发包，向服务器取得天气预报数据。
取得天气预报数据后，弹出窗口提示，隐藏listbox。
程序演示如图：
 - Option Explicit
- Sub t(sea As String)
- Dim url As String, tmp, arr, i&
- url = "http://toy.weather.com.cn/SearchBox/searchBox?keyword=" & Escape(Trim(sea)) '设置城市名的查询URL
- On Error Resume Next
- With CreateObject("Microsoft.XMLHTTP")
- .Open "get", url, False '发包
- .setRequestHeader "Connection", "keep-alive" '设置头部消息
- .setRequestHeader "DNT", "1"
- .send
- tmp = Split(.responsetext, "n"":""") '获取各城市名至数组
- End With
- If IsArray(tmp) Then
- tmp = Filter(tmp, "d"":""")
- ReDim arr(0 To UBound(tmp)) '整理文本数据流
- For i = 0 To UBound(tmp)
- arr(i) = Split(Split(tmp(i), "d"":""")(1), """,")(0) & "-" & Split(tmp(i), """,")(0) & ":" & Split(Split(tmp(i), "i"":""")(1), """,")(0)
- Next
- End If
- ListBox1.Visible = True '在列表框进行输出
- ListBox1.List = arr
- If Err <> 0 Then MsgBox "错误！"
- On Error GoTo 0
- End Sub
- Public Function Escape(ByVal strText As String) As String '转码，将文字转为URL可用的内码向服务器发送
- Dim JS As Object
- Set JS = CreateObject("scriptcontrol")
- JS.Language = "JavaScript"
- Escape = JS.Eval("encodeURI('" & Replace(strText, "'", "\'") & "');")
- End Function
- Private Sub ListBox1_Click()
- Call qi(Trim(Str(Split(ListBox1.List(ListBox1.ListIndex), ":")(1)))) '一旦被点击，识别被选中的项目，调用天气查询的程序
- ListBox1.Clear
- ListBox1.Visible = False
- TextBox1.Value = ""
- End Sub
- Private Sub TextBox1_Change()
- If Len(Trim(TextBox1.Value)) > 0 Then Call t(TextBox1.Value) Else ListBox1.Clear: ListBox1.Visible = False '调用城市查询程序
- End Sub
- Private Sub UserForm_Initialize() '初始化界面，使Listbox隐藏
- ListBox1.Clear
- ListBox1.Visible = False
- End Sub
- Sub qi(dai As String)
- Dim xmlhttp As Object, dqyb As String, jryb As String
- Dim url As String
- url = "http://www.weather.com.cn/data/sk/" & dai & ".html" '查询所点击的天气预报
- Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
- On Error Resume Next
- With xmlhttp
- .Open "get", url, False '发包获取气温
- .send
- dqyb = Split(Split(.responsetext, "city"":""")(1), """")(0) & "当前气温：" & Split(Split(.responsetext, "temp"":""")(1), """")(0) & "度"
- .Open "get", "http://www.weather.com.cn/weather/" & dai & ".shtml", False '发包获取一周预报
- .send
- jryb = "Today is " & Trim(Split(Split(.responsetext, "一周天气预报:")(1), "</title>")(0))
- End With
- Set xmlhttp = Nothing
- If Err <> 0 Then MsgBox "错误！" Else MsgBox dqyb & vbCrLf & jryb
- On Error GoTo 0
- End Sub
- Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
- Application.Visible = True
- Application.Quit
- End Sub
 天气查询.zip
|
