天气预报源代码

想不想在自己编写的程序中加入天气预报的内容？没问题！下面的代码能满足你的要求。
几点说明：
一、将代码复制到记事本，另存为 Form1.frm，把这个窗体加入到工程中，然后点击：工程→部件→控件，勾选 Microsoft Internet Controls 项，从工具箱中把WebBrowser控件画到窗体上。
二、本代码采取用户输入地名拼音的方式。
三、本代码链接到新浪天气预报来获取天气数据。
四、本代码在win7系统下调试通过，没在XP机上试验。
代码如下：

VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "ieframe.dll"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "天气预报"
   ClientHeight    =   4200
   ClientLeft      =   -15
   ClientTop       =   330
   ClientWidth     =   11295
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4200
   ScaleWidth      =   11295
   StartUpPosition =   3  '窗口缺省
   Begin VB.ComboBox Combo1 
      BackColor       =   &H8000000F&
      BeginProperty Font 
         Name            =   "楷体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00800080&
      Height          =   405
      Left            =   240
      TabIndex        =   2
      Text            =   "suzhou"
      Top             =   120
      Width           =   1815
   End
   Begin SHDocVwCtl.WebBrowser WebBrowser1 
      Height          =   30
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   30
      ExtentX         =   53
      ExtentY         =   53
      ViewMode        =   0
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   1
      AutoArrange     =   0   'False
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      NoWebView       =   0   'False
      HideFileNames   =   0   'False
      SingleClick     =   0   'False
      SingleSelection =   0   'False
      NoFolders       =   0   'False
      Transparent     =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   "http:///"
   End
   Begin VB.CommandButton Command1 
      Caption         =   "获取天气数据"
      BeginProperty Font 
         Name            =   "楷体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   2160
      TabIndex        =   0
      Top             =   120
      Width           =   2295
   End
   Begin VB.Label Label2 
      Appearance      =   0  'Flat
      BackColor       =   &H00FFC0FF&
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   0
      Left            =   2400
      TabIndex        =   6
      Top             =   840
      Width           =   3015
   End
   Begin VB.Label Label4 
      Appearance      =   0  'Flat
      BackColor       =   &H00C0C0FF&
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   0
      Left            =   8640
      TabIndex        =   5
      Top             =   840
      Width           =   2415
   End
   Begin VB.Label Label3 
      Appearance      =   0  'Flat
      BackColor       =   &H00FFC0C0&
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   0
      Left            =   5520
      TabIndex        =   4
      Top             =   840
      Width           =   3015
   End
   Begin VB.Label Label1 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   375
      Index           =   0
      Left            =   240
      TabIndex        =   3
      Top             =   840
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function SetProcessWorkingSetSize Lib "kernel32 " (ByVal hProcess As Long, ByVal dwMinimumWorkingSetSize As Long, ByVal dwMaximumWorkingSetSize As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32 " () As Long

Private Sub 获取天气数据()
On Error GoTo 100
Dim weather(1) As String, erature As String, tem As String
Dim i As Integer
Dim x, z

WebBrowser1.Silent = True
WebBrowser1.Navigate "http://weather.sina.com.cn/" & Combo1.Text

Do
  DoEvents   '等待WebBrowser控件加载完毕
  If WebBrowser1.ReadyState = 4 Then '如果准备就绪
    x = WebBrowser1.Document.getelementbyid("blk_fc_c0_scroll").All '获取所有数据
    If LCase(x.tagname) = "div" Then
      i = 0
      For Each z In x.getelementsbytagname("p")(2).All
        If LCase(z.tagname) = "img" Then
          weather(i) = IIf(i = 0, "白天：", "夜间：") & z.Title
          i = i + 1: tem = z.Title
        End If
      Next
      Label1(0) = x.getelementsbytagname("p")(0).innertext & "(" & x.getelementsbytagname("p")(1).innertext & ")" '日期和星期
      erature = x.getelementsbytagname("p")(4).innertext '气温
      i = InStr(erature, "/") '白天可获取昼/夜2个数据，用斜杠分隔。晚上只能获取1个夜数据，没有斜杠
      If i Then
        Label2(0) = weather(0) & "，" & Left(erature, i - 1)
        Label3(0) = weather(1) & "，" & Mid(erature, i + 2)
      Else
        Label2(0) = "白天："
        Label3(0) = "夜间：" & tem & "，" & erature
      End If
      Label4(0) = x.getelementsbytagname("p")(5).innertext '风向风速
    End If
    Exit Do
  End If
Loop

100
If Err.Number Then MsgBox "发生了错误"
SetProcessWorkingSetSize GetCurrentProcess(), -1&, -1&
End Sub

Private Sub Combo1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then 获取天气数据
End Sub

Private Sub Command1_Click()
获取天气数据
End Sub

如果细心一点，你一定会发现显示天气用的标签都是控件数组的形式，这是为扩容做的准备。因为新浪天气最多可取得７天的数据，你可以根据实际需要的天数改动“Private Sub 获取天气数据()”过程的代码， 并增加“Form_Load()”过程，例如７天的预报代码修改如下：

Private Sub Form_Load()
Dim i As Integer
For i = 1 To 6
  Load Label1(i): Label1(i).Move Label1(0).Left, (Label1(i - 1).Height + 60) * i + 840: Label1(i).Visible = True
  Load Label2(i): Label2(i).Move Label2(0).Left, (Label2(i - 1).Height + 60) * i + 840: Label2(i).Visible = True
  Load Label3(i): Label3(i).Move Label3(0).Left, (Label3(i - 1).Height + 60) * i + 840: Label3(i).Visible = True
  Load Label4(i): Label4(i).Move Label4(0).Left, (Label4(i - 1).Height + 60) * i + 840: Label4(i).Visible = True
Next
End Sub

Private Sub 获取天气数据()
On Error GoTo 100
Dim erature As String, weather(1) As String, tem As String
Dim i As Integer, j As Integer
Dim x, z

WebBrowser1.Silent = True
WebBrowser1.Navigate "http://weather.sina.com.cn/" & Combo1.Text

Do
  DoEvents
  If WebBrowser1.ReadyState = 4 Then
    For Each x In WebBrowser1.Document.getelementbyid("blk_fc_c0_scroll").All
      If LCase(x.tagname) = "div" Then
        i = 0
        For Each z In x.getelementsbytagname("p")(2).All
          If LCase(z.tagname) = "img" Then weather(i) = IIf(i = 0, "白天：", "夜间：") & z.Title
          i = i + 1: tem = z.Title
        Next
        erature = x.getelementsbytagname("p")(4).innertext '气温
        i = InStr(erature, "/") '20点前可获取昼/夜2个数据，用斜杠分隔。20点后只能获取1个夜数据，没有斜杠
        Label1(j) = x.getelementsbytagname("p")(0).innertext & "(" & x.getelementsbytagname("p")(1).innertext & ")" '日期和星期
        Label2(j) = IIf(i, weather(0) & "，" & Left(erature, i - 1), "白天：")
        Label3(j) = IIf(i, weather(1) & "，" & Mid(erature, i + 2), "夜间：" & tem & "，" & erature)
        Label4(j) = x.getelementsbytagname("p")(5).innertext
        j = j + 1: If j > 6 Then Exit For
      End If
    Next
    Exit Do
  End If
Loop

100
If Err.Number Then MsgBox "发生了错误"
SetProcessWorkingSetSize GetCurrentProcess(), -1&, -1&
End Sub

本代码也可以输入汉字，而由程序内部查表转换为拼音，这只要增加一些代码即可实现。但是要注意：多音字可能会报错。例如“重庆”查表的结果为“zhongqing”，出错。另外，本代码的汉字 Ascii 码表从 -20319～-10254，如果超出这个范围也会报错，例如“圳”的 Ascii 码是 -9254，超出了范围，所以输入“深圳”也会出错。遇到这两种情况，就只能输入拼音了。修改如下：
①首先声明2个窗体级变量：

Option Explicit
Dim ascs() As String, keys() As String

②在”Form_Load()“过程中添加：

Dim d As String
d = "a|ai|an|ang|ao|ba|bai|ban|bang|bao|bei|ben|beng|bi|bian|biao|bie|bin|bing|bo|bu|" & _
"ca|cai|can|cang|cao|ce|ceng|cha|chai|chan|chang|chao|che|chen|cheng|chi|chong|chou|" & _
"chu|chuai|chuan|chuang|chui|chun|chuo|ci|cong|cou|cu|cuan|cui|cun|cuo|da|dai|dan|" & _
"dang|dao|de|deng|di|dian|diao|die|ding|diu|dong|dou|du|duan|dui|dun|duo|e|en|er|" & _
"fa|fan|fang|fei|fen|feng|fo|fou|fu|ga|gai|gan|gang|gao|ge|gei|gen|geng|gong|gou|" & _
"gu|gua|guai|guan|guang|gui|gun|guo|ha|hai|han|hang|hao|he|hei|hen|heng|hong|hou|" & _
"hu|hua|huai|huan|huang|hui|hun|huo|ji|jia|jian|jiang|jiao|jie|jin|jing|jiong|jiu|" & _
"ju|juan|jue|jun|ka|kai|kan|kang|kao|ke|ken|keng|kong|kou|ku|kua|kuai|kuan|kuang|" & _
"kui|kun|kuo|la|lai|lan|lang|lao|le|lei|leng|li|lia|lian|liang|liao|lie|lin|ling|" & _
"liu|long|lou|lu|lv|luan|lue|lun|luo|ma|mai|man|mang|mao|me|mei|men|meng|mi|mian|" & _
"miao|mie|min|ming|miu|mo|mou|mu|na|nai|nan|nang|nao|ne|nei|nen|neng|ni|nian|niang|" & _
"niao|nie|nin|ning|niu|nong|nu|nv|nuan|nue|nuo|o|ou|pa|pai|pan|pang|pao|pei|pen|" & _
"peng|pi|pian|piao|pie|pin|ping|po|pu|qi|qia|qian|qiang|qiao|qie|qin|qing|qiong|qiu|" & _
"qu|quan|que|qun|ran|rang|rao|re|ren|reng|ri|rong|rou|ru|ruan|rui|run|ruo|sa|sai|" & _
"san|sang|sao|se|sen|seng|sha|shai|shan|shang|shao|she|shen|sheng|shi|shou|shu|shua|" & _
"shuai|shuan|shuang|shui|shun|shuo|si|song|sou|su|suan|sui|sun|suo|ta|tai|tan|tang|" & _
"tao|te|teng|ti|tian|tiao|tie|ting|tong|tou|tu|tuan|tui|tun|tuo|wa|wai|wan|wang|" & _
"wei|wen|weng|wo|wu|xi|xia|xian|xiang|xiao|xie|xin|xing|xiong|xiu|xu|xuan|xue|xun|" & _
"ya|yan|yang|yao|ye|yi|yin|ying|yo|yong|you|yu|yuan|yue|yun|za|zai|zan|zang|zao|" & _
"ze|zei|zen|zeng|zha|zhai|zhan|zhang|zhao|zhe|zhen|zheng|zhi|zhong|zhou|zhu|zhua|" & _
"zhuai|zhuan|zhuang|zhui|zhun|zhuo|zi|zong|zou|zu|zuan|zui|zun|zuo|"
keys = Split(d, "|")

d = "20319|20317|20304|20295|20292|20283|20265|20257|20242|20230|20051|20036|20032|20026|20002|19990|19986|" & _
"19982|19976|19805|19784|19775|19774|19763|19756|19751|19746|19741|19739|19728|19725|19715|19540|19531|" & _
"19525|19515|19500|19484|19479|19467|19289|19288|19281|19275|19270|19263|19261|19249|19243|19242|19238|" & _
"19235|19227|19224|19218|19212|19038|19023|19018|19006|19003|18996|18977|18961|18952|18783|18774|18773|" & _
"18763|18756|18741|18735|18731|18722|18710|18697|18696|18526|18518|18501|18490|18478|18463|18448|18447|" & _
"18446|18239|18237|18231|18220|18211|18201|18184|18183|18181|18012|17997|17988|17970|17964|17961|17950|" & _
"17947|17931|17928|17922|17759|17752|17733|17730|17721|17703|17701|17697|17692|17683|17676|17496|17487|" & _
"17482|17468|17454|17433|17427|17417|17202|17185|16983|16970|16942|16915|16733|16708|16706|16689|16664|" & _
"16657|16647|16474|16470|16465|16459|16452|16448|16433|16429|16427|16423|16419|16412|16407|16403|16401|" & _
"16393|16220|16216|16212|16205|16202|16187|16180|16171|16169|16158|16155|15959|15958|15944|15933|15920|" & _
"15915|15903|15889|15878|15707|15701|15681|15667|15661|15659|15652|15640|15631|15625|15454|15448|15436|" & _
"15435|15419|15416|15408|15394|15385|15377|15375|15369|15363|15362|15183|15180|15165|15158|15153|15150|" & _
"15149|15144|15143|15141|15140|15139|15128|15121|15119|15117|15110|15109|14941|14937|14933|14930|14929|" & _
"14928|14926|14922|14921|14914|14908|14902|14894|14889|14882|14873|14871|14857|14678|14674|14670|14668|" & _
"14663|14654|14645|14630|14594|14429|14407|14399|14384|14379|14368|14355|14353|14345|14170|14159|14151|" & _
"14149|14145|14140|14137|14135|14125|14123|14122|14112|14109|14099|14097|14094|14092|14090|14087|14083|" & _
"13917|13914|13910|13907|13906|13905|13896|13894|13878|13870|13859|13847|13831|13658|13611|13601|13406|" & _
"13404|13400|13398|13395|13391|13387|13383|13367|13359|13356|13343|13340|13329|13326|13318|13147|13138|" & _
"13120|13107|13096|13095|13091|13076|13068|13063|13060|12888|12875|12871|12860|12858|12852|12849|12838|" & _
"12831|12829|12812|12802|12607|12597|12594|12585|12556|12359|12346|12320|12300|12120|12099|12089|12074|" & _
"12067|12058|12039|11867|11861|11847|11831|11798|11781|11604|11589|11536|11358|11340|11339|11324|11303|" & _
"11097|11077|11067|11055|11052|11045|11041|11038|11024|11020|11019|11018|11014|10838|10832|10815|10800|" & _
"10790|10780|10764|10587|10544|10533|10519|10331|10329|10328|10322|10315|10309|10307|10296|10281|10274|" & _
"10270|10262|10260|10256|10254|"
ascs = Split(d, "|")

③增加一个过程：

Private Function Getpy(Txt) As String '返回汉字串的拼音
Dim hzCode, TmpTxt As String, spell As String, i As Integer, j As Integer

For i = 1 To Len(Txt)
  hzCode = Asc(Mid(Txt, i, 1))
  If hzCode > 0 And hzCode < 160 Then
    spell = Chr(hzCode)
  Else
    If hzCode < -20319 Or hzCode > -10247 Then
      spell = ""
    Else
      For j = 395 To 0 Step -1
        If -Val(ascs(j)) <= hzCode Then Exit For
      Next
      spell = keys(j)
    End If
  End If
  TmpTxt = TmpTxt & spell
Next

Getpy = TmpTxt
End Function

④将”Sub 获取天气数据()“过程中的 Combo1.Text 替换为 Getpy(Combo1.Text)