取天气预报(用lotus)

代理执行：

Sub Initialize
 On Error Goto errorhandle
 Dim ss As New NotesSession
 Dim db As NotesDatabase
 Dim doc As NotesDocument
 Dim rtnav As NotesRichTextNavigator
 Dim body As NotesRichTextItem
 
 Dim xmldoc As Variant
 Dim url As String
 Dim strHtml  As String
 Dim strToday As String
 Dim vartemp As String
 Dim strtemp As String
 Dim varcontent(2) As String
 Dim strsubject As String
 Dim pos1 As Integer
 Dim pos2 As Integer
 
 Set db = ss.CurrentDatabase
 
 On Error Resume Next
 
 Set xmldoc = CreateObject("Microsoft.XMLHTTP") 
 
 If xmldoc Is Nothing Then
  Exit Sub
 End If
 
 url ="http://weather.cn.yahoo.com/weather.html?city=%E6%9D%AD%E5%B7%9E"
 Call xmldoc.open("GET",url,False)  
 Call xmldoc.setRequestHeader("Content-Type", "application/x-www-form-urlencoded" )
 
 xmldoc.send(Null)
 
 If xmldoc.readyState = 4 Then   
  strHtml = xmldoc.ResponseText 
  pos1 = Instr(strHtml,"start:今日")
  pos2 = Instr(strHtml,"end:今日")
  vartemp = Mid(strHtml,pos1,pos2-pos1)
  strtemp = getText(vartemp)
  strsubject = "今天："+strtemp + ";"
  varcontent(0) = "  今天："+ Chr(13) + Chr(10) +getContent(vartemp)
  
  pos1 = Instr(strHtml,"start:明日")
  pos2 = Instr(strHtml,"end:明日")
  vartemp = Mid(strHtml,pos1,pos2-pos1)
  strtemp = getText(vartemp)
  strsubject = strsubject + "明天：" + strtemp + ";"
  varcontent(1) = "  明天："+ Chr(13) + Chr(10) +getContent(vartemp)
  
  pos1 = Instr(strHtml,"start:后天")
  pos2 = Instr(strHtml,"end:后天")
  vartemp = Mid(strHtml,pos1,pos2-pos1)
  strtemp = getText(vartemp)
  strsubject = strsubject + "后天：" + strtemp + ";"
  varcontent(2) = "  后天："+ Chr(13) + Chr(10) +getContent(vartemp)
  
  Set doc = New NotesDocument(db)
  doc.Form = "ElectronicBoardView_Form"
  doc.SubjectOS = strsubject
  doc.CreatorOS = ss.UserName
  
  Set body = New NotesRichTextItem(doc,"content")
  
  rowCount% = 3
  columnCount% = 1
  
  Call body.AppendTable(rowCount%, columnCount%,,RULER_ONE_INCH * 1.5)
  
  Set rtnav = body.CreateNavigator
  Call rtnav.FindFirstElement(RTELEM_TYPE_TABLECELL)
  
  For i = 0 To 2
   Call body.BeginInsert(rtnav)
   Call body.AppendText(varcontent(i))
   Call body.EndInsert
   Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
  Next
  
  Call WeatherPublic(doc)
 End If
 
 Exit Sub
 Exit Sub
ErrorHandle:
 Call RecordErrorLog("getWeather_Agent","Initialize",Erl,Err,Error)
 Exit Sub
End Sub 

Function getText(strcontent As String) As String
 Dim vartemp As Variant
 Dim pos1 As Integer
 Dim pos2 As Integer
 
 vartemp = Split(strcontent,"<span")
 If Isarray(vartemp) Then
  vartemp = vartemp(2)
  pos1 = Instr(vartemp,"<strong>")
  pos2 = Instr(vartemp,"</span></p>")
  vartemp = Mid(vartemp,pos1+8,pos2-pos1-8)
  vartemp = Replace(vartemp,"</strong>","")
  getText = vartemp
 End If
End Function

Function getContent(strcontent As String) As String
 Dim vartemp As Variant
 Dim pos1 As Integer
 Dim pos2 As Integer
 
 vartemp = Split(strcontent,"<div")
 If Isarray(vartemp) Then
  vartemp = vartemp(3)
  vartemp = Replace(vartemp,"<p>","")
  vartemp = Replace(vartemp,"</p>","")
  vartemp = Replace(vartemp,"<label>","")
  vartemp = Replace(vartemp,"</label>","")
  vartemp = Strleft(vartemp,"<")
  vartemp = Strright(vartemp,">")
  
  getContent = vartemp
 End If
End Function

 

[这个函数“WeatherPublic”是要发布文档的后续处理

在取天气预报中会遇到的错误主要是创建Microsoft.XMLHTTP对象时会出现“cannot create automation object”的错误，处理办法：在服务器上重新注册msxml.dll组件（regsvr32 msxml.dll）