VB 天气预报源代码

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As LongPrivate Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPrivate Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As LongPrivate Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPrivate Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Type POINTAPIX As LongY As LongEnd TypePrivate Declare Function ReleaseCapture Lib "user32" () As LongPrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Const HTCAPTION = 2Private Const WM_NCLBUTTONDOWN = &HA1Private Const WS_EX_LAYERED As Long = &H80000Private Const LWA_ALPHA As Long = &H2Private Const GWL_EXSTYLE = (-20)Private Const RDW_INVALIDATE = &H1Private Const RDW_ERASE = &H4Private Const RDW_ALLCHILDREN = &H80Private Const RDW_FRAME = &H400Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As LongPrivate Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As LongPrivate Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As BooleanPrivate Type NOTIFYICONDATAcbSize As Longhwnd As LongUID As LonguFlags As LonguCallbackMessage As LonghIcon As LongszTip As String * 64End TypePrivate Const NIM_ADD = &H0Private Const NIM_MODIFY = &H1Private Const NIM_DELETE = &H2Private Const NIF_MESSAGE = &H1Private Const NIF_ICON = &H2Private Const NIF_TIP = &H4Private Const NIF_DOALL = NIF_MESSAGE Or NIF_ICON Or NIF_TIPPrivate Const WM_MOUSEMOVE = &H200Private Const WM_LBUTTONDBLCLK = &H203Private Const WM_LBUTTONDOWN = &H201Private Const WM_LBUTTONUP = &H202Private Const WM_RBUTTONDBLCLK = &H206Private Const WM_RBUTTONDOWN = &H204Private Const WM_RBUTTONUP = &H205Dim zhishu(7) As StringDim isend As BooleanDim Allzhishu As StringDim pos As SingleDim Bleft As Boolean '向坐移动Dim ph As Single '当前透明度Dim temppos As String '当前地名Dim IsGetIp As BooleanDim CurrTime As Integer '累计时间Dim isshow As BooleanDim index As IntegerDim IsSet As Boolean '是否已经设置窗体大小Private Sub closebutton_Click()Unload MeEnd SubPrivate Sub closebutton_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)closebutton.Picture = close3.PictureEnd SubPrivate Sub closebutton_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)closebutton.Picture = close2.PictureEnd SubPrivate Sub fengli_Click()On Error Resume NextIf ph >= 20 Thenph = ph - 10Elseph = 100End IfEnd SubPrivate Sub Form_Click()SetPhEnd SubPrivate Sub Form_Load()Dim i As IntegerDim oo As ObjectOn Error Resume NextAddIco Me, "天气预报"isshow = Trueph = 80CurrTime = 0Randomize Timerindex = Rnd * 10 + 1Call SetWindowLong(Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)SetLayeredWindowAttributes Me.hwnd, 0, (255 * ph) / 100, &H2For Each oo In Meoo.ForeColor = RGB(200, 39, 128)NextSetPicSet oo = NothingSetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 1riqi.Caption = "今天是:" & Date & GetWeekDayMe.Height = 5600IsGetIp = Falseweb1.Navigate ""End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Dim msg As Longmsg = X / Screen.TwipsPerPixelXIf msg = WM_LBUTTONDOWN ThenIf isshow = True ThenMe.Hideisshow = FalseElseMe.Showisshow = TrueEnd IfEnd IfEnd SubPrivate Sub Form_Resize()On Error Resume NextChangeWindowPrivate Sub ChangeWindow()setformSetPosRgnMeEnd SubPublic Sub RgnMe()Dim hgc As Longhgc = CreateRoundRectRgn(0, 0, Me.Width / 15, Me.Height / 15, 15, 15)SetWindowRgn Me.hwnd, hgc, TrueEnd SubPrivate Sub SetPos()End Sub'重画窗体Private Sub setform()Me.PaintPicture pic1.Picture, 0, 0, Me.Width, 350, 10, 10, 300, 200Me.PaintPicture pic1.Picture, 0, Me.Height - 80, Me.Width, 80, 10, 100, 300, 100 Me.PaintPicture pic1.Picture, 0, 350, 80, Me.Height, 10, 100, 300, 100Me.PaintPicture pic1.Picture, Me.Width - 80, 350, 80, Me.Height, 10, 100, 300, 100Me.PaintPicture pic1.Picture, 80, 350, Me.Width - 150, Me.Height - 420, 10, 10, 300, 10End SubPrivate Sub SetPh()On Error Resume NextIf ph >= 20 Thenph = ph - 10Elseph = 100End IfCall SetWindowLong(Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)SetLayeredWindowAttributes Me.hwnd, 0, (255 * ph) / 100, &H2End SubPrivate Sub Form_Unload(Cancel As Integer)DeleteIcon MeEnd SubPrivate Sub kongqi_Click()SetPhEnd SubPrivate Sub pic2_Click()SetPhEnd SubPrivate Sub position_Click()SetPhEnd SubPrivate Sub riqi_DblClick()If index < 12 Thenindex = index + 1index = 1End IfSetPicChangeWindowEnd SubPrivate Sub riqi_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)If Button = 1 ThenReleaseCaptureSendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&End IfEnd SubPrivate Sub tfengli_Click()On Error Resume NextSetPhEnd SubPrivate Sub tianqi_Click()On Error Resume NextSetPhEnd SubPrivate Sub Timer1_Timer()On Error Resume NextIf pos >= -TextWidth(Allzhishu) + 500 Thenpos = pos - 30Elsepos = pic2.WidthEnd Ifpic2.Clspic2.PaintPicture pic1.Picture, 0, 0, pic2.Width, pic2.Height, 10, 10, 300, 10 pic2.CurrentX = pospic2.CurrentY = 50pic2.Print AllzhishuEnd SubPrivate Sub minbut_Click()Me.Hideisshow = FalseEnd SubPrivate Sub minbut_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)minbut.Picture = min3.PictureEnd SubPrivate Sub minbut_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)minbut.Picture = min2.PictureEnd SubPrivate Sub riqi_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)minbut.Picture = min1.Pictureclosebutton.Picture = close1.PictureEnd SubPrivate Sub Timer2_Timer()If CurrTime < 10 ThenCurrTime = CurrTime + 1ElseCurrTime = 0OpenUrlEnd IfEnd SubPrivate Sub ttianqi_Click()On Error Resume NextSetPhEnd SubPrivate Sub web1_DownloadComplete()On Error Resume NextDim i As IntegerDim stemp As StringDim max As Integermax = 0stemp = GetText(web1)If stemp <> "" ThenGetIP stempweb2.Visible = TrueOpenUrlSetMaxEnd IfEnd SubPrivate Function GetText(web1 As WebBrowser) As String 'On Error Resume NextDim stemp As StringDim oo As Objectstemp = ""For Each oo In web1.Document.AllDoEventsstemp = stemp & oo.innerhtmlNext' If InStr(stemp, "找不到服务器") Then' MsgBox "读取信息失败，请确认网络已经连接", vbCritical, "天气预报" ' ElseGetText = stemp' End IfSet oo = NothingEnd FunctionPrivate Sub OpenUrl()web2.Navigate "/weatherdetail/54511.html"End SubPrivate Function GetIP(stemp As String)On Error Resume NextDim temp() As Stringtemp = Split(stemp, "您的IP是：")ip.Caption = "您的IP是:" & Mid(temp(1), 1, InStr(temp(1), "<") - 1)temp = Split(temp(1), "您的位置是：")position.Caption = "您的位置是:" & Mid(temp(1), 1, InStr(temp(1), "<") - 1) temppos = Mid(temp(1), 1, InStr(temp(1), "<") - 1)isend = FalseEnd FunctionPrivate Function Getzhishu(stemp As String)On Error Resume NextDim temp() As StringDim i As Integertemp = Split(stemp, "穿衣指数")temp = Split(LCase(temp(1)), "table")temp = Split(LCase(temp(0)), "title=")zhishu(0) = "穿衣指数:" & Left(temp(1), InStr(LCase(temp(1)), "style") - 1) zhishu(1) = "感冒指数:" & Left(temp(2), InStr(LCase(temp(2)), "style") - 1) zhishu(2) = "晨练指数:" & Left(temp(3), InStr(LCase(temp(3)), "style") - 1) zhishu(3) = "交通指数:" & Left(temp(4), InStr(LCase(temp(4)), "style") - 1) zhishu(4) = "中暑指数:" & Left(temp(5), InStr(LCase(temp(5)), "style") - 1) zhishu(5) = "公园指数:" & Left(temp(6), InStr(LCase(temp(6)), "style") - 1) zhishu(6) = "防晒指数:" & Left(temp(7), InStr(LCase(temp(7)), "style") - 1) zhishu(7) = "旅行指数:" & Left(temp(8), InStr(LCase(temp(8)), "style") - 1) Allzhishu = ""For i = 0 To 7Allzhishu = Allzhishu & zhishu(i)Next ipos = pic2.Widthpic2.CurrentX = pospic2.CurrentY = 50pic2.Print AllzhishuBleft = TrueTimer1.Enabled = TrueEnd Function'得到当前的天气情况Private Sub GetCurrReport(stemp As String)On Error Resume NextDim temp() As StringDim temp1() As Stringtemp = Split(LCase(stemp), "<ul class=")temp = Split(LCase(temp(1)), "</div>")temp1 = Split(LCase(temp(0)), "<li>")tianqi.Caption = "现在天气:" & temp1(1)wendu.Caption = "现在温度:" & Left(temp1(2), InStr(temp1(2), "<") - 1)temp = Split(temp(1), "<li class=")temp1 = Split(temp(1), ">")fengli.Caption = temp1(1)temp1 = Split(temp(2), ">")ziwaixian.Caption = temp1(1)temp1 = Split(temp(3), ">")kongqi.Caption = Left(temp1(1), InStr(temp1(1), "<") - 1)tttianqi.Caption = "明天天气:" & GetTweather(stemp)End SubPrivate Function GetTweather(stemp As String) As StringDim temp() As Stringtemp = Split(stemp, "天气概况")temp = Split(LCase(temp(1)), "</td>")temp = Split(LCase(temp(7)), ">")GetTweather = temp(1)End Function'得到今天的总情况Private Sub GetReport(stemp As String)On Error Resume NextDim temp() As StringDim temp1() As Stringtemp = Split(stemp, "找不到服务器")If UBound(temp) > 0 ThenExit SubElsetemp = Split(stemp, "气温")temp = Split(LCase(temp(1)), "<tr>")temp1 = Split(temp(0), ">")ttianqi.Caption = "今天温度:" & Left(temp1(2), InStr(temp1(2), "<") - 1) ttwendu.Caption = "明天温度:" & Left(temp1(4), InStr(temp1(4), "<") - 1) temp1 = Split(temp(1), ">")tfengli.Caption = "今天风力:" & Left(temp1(3), InStr(temp1(3), "<") - 1) ttfengli.Caption = "明天风力:" & Left(temp1(5), InStr(temp1(5), "<") - 1) End IfEnd SubPrivate Sub GetDagai(stemp As String)On Error Resume NextDim temp() As Stringtemp = Split(stemp, "天气概况")temp = Split(LCase(temp(1)), "</td>")temp = Split(temp(3), ">")gaikuang.Caption = "今天概况:" & temp(1)End SubPrivate Function GetWeekDay() As StringOn Error Resume NextSelect Case Weekday(Date)Case 1GetWeekDay = "星期日"Case 2GetWeekDay = "星期一"Case 3GetWeekDay = "星期二"Case 4GetWeekDay = "星期三"Case 5GetWeekDay = "星期四"Case 6GetWeekDay = "星期五"Case 7GetWeekDay = "星期六"End SelectEnd FunctionPrivate Sub web2_DownloadComplete() Dim stemp As Stringstemp = GetText(web2)If stemp <> "" ThenGetCurrReport stempGetzhishu stempGetDagai stempGetReport stempTimer2.Enabled = TrueIf IsSet = False ThenSetMaxIsSet = TrueEnd IfEnd IfEnd SubPrivate Sub SetMax()On Error Resume NextDim max As SingleDim oo As Objectmax = 0For Each oo In MeIf max <= oo.Width Then max = oo.Width NextMe.Width = max + 250End SubPrivate Sub wendu_Click()On Error Resume NextSetPhEnd SubPrivate Sub wendu_DblClick()On Error Resume NextSetPhEnd Sub'添加图标到系统托盘Public Sub AddIco(frm As Form, Information)Dim LPICON As LongDim Tic As NOTIFYICONDATATic.cbSize = Len(Tic)Tic.hwnd = frm.hwndTic.UID = 1&Tic.uFlags = NIF_DOALLTic.uCallbackMessage = WM_MOUSEMOVETic.hIcon = frm.IconTic.szTip = Information & Chr$(0)LPICON = Shell_NotifyIcon(NIM_ADD, Tic) End Sub'删除图标Public Sub DeleteIcon(frm As Form)Dim LPICON As LongDim Tic As NOTIFYICONDATATic.cbSize = Len(Tic)Tic.hwnd = frm.hwndTic.UID = 1&LPICON = Shell_NotifyIcon(NIM_DELETE, Tic) End Sub。