使Pandion自动从谷歌获取天气信息更新签名

Option ExplicitConst SETFILE = "C:/Documents and Settings/Administrator/Application Data/Pandion/Profiles/{USER}@messiahrpe/settings.xml"Dim strSetFile As StringDim objTimer As New clsWaitableTimerDim strLastWeatherInfo As StringSub Main() Dim strData$, strWeather$, strLog$ Dim reg As Object Dim matchs As Object, match As Object If App.PrevInstance Then End strSetFile = Replace(SETFILE, "{USER}", App.EXEName) strData = ReadUTF8(strSetFile) strLog = ReadUTF8("shell.txt") Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.IgnoreCase = True reg.Pattern = "<lastmsg>.*</lastmsg>" Do strWeather = getWeather() If strWeather = "" Then strWeather = "Failed to get weather infomation!" If strWeather <> strLastWeatherInfo Then strData = reg.Replace(strData, "<lastmsg>" & strWeather & "</lastmsg>") If SaveFile(strSetFile, strData) Then strLastWeatherInfo = strWeather SaveFile "shell.txt", strLog & Format(Now, "yyyy-mm-dd hh:nn:ss ") & strWeather & vbCrLf terminateProcessB "Pandion.exe" Shell "C:/Program Files/Pandion/Pandion.exe", 1 End If End If objTimer.Wait 300000 '5min LoopEnd SubPrivate Function getWeather() As String Dim strData$ Dim reg As Object Dim matchs As Object, match As Object Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.IgnoreCase = True reg.Pattern = "<div>当前： .*?<br>(.*?)<br>.*?今日.*?alt=""(.*?)"".*?<nobr>([-/d]+).*?([-/d]+).*?</nobr>.*?alt=""(.*?)"".*?<nobr>([-/d]+).*?([-/d]+).*?</nobr>" strData = GetHtmlByMicrosoftXMLHTTP("http://www.google.cn/search?q=tq", 1) Set matchs = reg.Execute(strData) If matchs.Count = 1 Then getWeather = "今日" & matchs(0).SubMatches(1) & " " & matchs(0).SubMatches(3) & "/" & matchs(0).SubMatches(2) & "° " & matchs(0).SubMatches(0) & " " & _ "明日" & matchs(0).SubMatches(4) & " " & matchs(0).SubMatches(6) & "/" & matchs(0).SubMatches(5) & "°" End IfEnd FunctionPublic Function GetHtmlByMicrosoftXMLHTTP(strUrl$, Optional intPageType As Integer = 0) As String Dim XmlHttp Set XmlHttp = CreateObject("Microsoft.XMLHTTP") XmlHttp.Open "GET", strUrl, False On Error GoTo Err_net XmlHttp.send If intPageType = 0 Then GetHtmlByMicrosoftXMLHTTP = StrConv(XmlHttp.responseBody, vbUnicode) Else GetHtmlByMicrosoftXMLHTTP = BytesToBstr(XmlHttp.responseBody, "UTF-8") End If Set XmlHttp = NothingErr_net:End Function'ﾗｪutf8ｸｽPrivate Function BytesToBstr(strBody, codeBase) As String Dim objStream As Object Set objStream = CreateObject("Adodb.Stream") objStream.Type = 1 objStream.Mode = 3 objStream.Open objStream.Write strBody objStream.position = 0 objStream.Type = 2 objStream.Charset = codeBase BytesToBstr = objStream.ReadText objStream.Close Set objStream = NothingEnd FunctionPublic Function SaveFile(FileName As Variant, strFileBody As Variant) As BooleanOn Error GoTo Err1 Dim ADO_Stream As Object Set ADO_Stream = CreateObject("ADODB.Stream") With ADO_Stream .Type = 2 .Mode = 3 .Charset = "utf-8" .Open .WriteText strFileBody .SaveToFile FileName, 2 End With SaveFile = True Set ADO_Stream = Nothing Exit FunctionErr1: SaveFile = False MsgBox "write to file error!" & vbCrLf & vbCrLf & FileName, vbExclamationEnd FunctionPublic Function ReadUTF8(ByVal sUTF8File As String) As String If Len(sUTF8File) = 0 Or Dir(sUTF8File) = vbNullString Then Exit Function Dim ados As Object Set ados = CreateObject("ADODB.Stream") With ados .Charset = "utf-8" .Type = 2 .Open .LoadFromFile sUTF8File ReadUTF8 = .ReadText .Close End With Set ados = NothingEnd FunctionPrivate Sub terminateProcessB(ByVal proName As String) Dim objWMIService As Object Dim colProcessList As Object Dim objProcess As Object Set objWMIService = GetObject("winmgmts:" & "{impersonationlevel=impersonate}!//./root/cimv2") Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name='" & proName & "'") If colProcessList.Count <> 0 Then For Each objProcess In colProcessList objProcess.Terminate Next End IfEnd Sub

 

效果图：