[Lotus Notes]自动更新的天气预报数据库（下）

接下来我们要做两个共享Action，以便用户可以订阅（撤订）某个城市的预报邮件。为什么做成共享的呢？是为了可以在多个试图中使用。我们还要创建一个代理来定时发送天气预报邮件。下面是这两个Action和定时代理的代码。

1。订阅Action

Sub Click(Source As Button)

Dim s As New NotesSession

Dim db As NotesDatabase

Dim view As NotesView

Dim Adoc As NotesDocument

Dim doc As NotesDocument

Redim Key(1)

Redim BNames(0)

Dim i As Integer

Dim t As Integer

Set doc=s.DocumentContext

If doc Is Nothing Then

Msgbox "You should select 24Hour document, not just city name."

Exit Sub

End If

Set db=s.CurrentDatabase

Set view=db.GetView("WeaLookup")

Key(0)=doc.CityName(0)

Key(1)="0"

t=0

Set Adoc=view.GetDocumentByKey(Key)

If Adoc.BookNames(0)<>"" Then

For i=0 To Ubound(Adoc.BookNames)

If Adoc.BookNames(i)=s.CommonUserName Then

Msgbox "You already book this Weather Forecast."

Exit Sub

End If

If Adoc.BookNames(i)<>"" Then

BNames(t)=Adoc.BookNames(i)

t=t+1

Redim Preserve BNames(t)

End If

BNames(t)=s.CommonUserName

Adoc.BookNames=BNames

Else

Adoc.BookNames=s.CommonUserName

End If

Call Adoc.Save(True,True)

Msgbox "Book Weather Forecast for ["+key(0)+"] completed."+Chr(10)+_

"Weather information will send to your mailbox every morning."

End Sub

2。撤销订阅Action

Sub Click(Source As Button)

Dim s As New NotesSession

Dim db As NotesDatabase

Dim view As NotesView

Dim Adoc As NotesDocument

Dim doc As NotesDocument

Redim Key(1)

Redim BNames(0)

Dim i As Integer

Dim t As Integer

Dim found As Boolean

Set doc=s.DocumentContext

If doc Is Nothing Then

Msgbox "You should select 24Hour document, not just city name."

Exit Sub

End If

Set db=s.CurrentDatabase

Set view=db.GetView("WeaLookup")

Key(0)=doc.CityName(0)

Key(1)="0"

Set Adoc=view.GetDocumentByKey(Key)

t=0

found=False

If Adoc.BookNames(0)<>"" Then

For i=0 To Ubound(Adoc.BookNames)

If Adoc.BookNames(i)<>s.CommonUserName Then

BNames(t)=Adoc.BookNames(i)

t=t+1

Redim Preserve BNames(t)

Else

found=True

End If

If found Then

Adoc.BookNames=BNames

Call Adoc.Save(True,True)

Msgbox "Cancel Weather Forecast for ["+key(0)+"] successed"

Else

Msgbox "You did not Subscribe Weather Forecast for ["+key(0)+"] before."

End If

Else

Msgbox "You did not Subscribe Weather Forecast for ["+key(0)+"] before."

End If

End Sub

3. 定时代理agent

Sub Initialize

Dim s As New NotesSession

Dim db As NotesDatabase

Dim mview As NotesView

Dim wview As NotesView

Dim dc As NotesDocumentCollection

Dim doc As NotesDocument

Dim wdoc As NotesDocument

Dim pdoc As NotesDocument

Dim Tseed As NotesItem

Dim rtnav As NotesRichTextNavigator

Dim rtt As NotesRichTextTable

Dim richStyle As NotesRichTextStyle

Set richStyle = s.CreateRichTextStyle

Set db=s.CurrentDatabase

Set mview=db.GetView("WeaMail")

Set wview=db.GetView("WeaLookup")

Set pdoc=db.GetProfileDocument("Profile")

Set doc=mview.GetFirstDocument

While Not doc Is Nothing

Set dc=wview.GetAllDocumentsByKey(doc.CityName(0))

Set wdoc=dc.GetFirstDocument

Set mail=New NotesDocument(db)

mail.form="Memo"

mail.subject="Weather Forecast for ["+doc.CityName(0)+"] CHS"

mail.principal="ASAP Weather Forecast Service"

Set rt=New NotesRichTextItem(mail,"Body")

richStyle.Bold = True

richStyle.NotesColor = COLOR_BLUE

richStyle.FontSize = 10

Call rt.AppendStyle(richStyle)

Call rt.appendtext("City Name: ")

Call rt.appendtext(doc.CityName(0))

Call rt.addnewline(1)

richStyle.Bold = False

richStyle.NotesColor = COLOR_BLACK

richStyle.FontSize = 9

Call rt.AppendStyle(richStyle)

Set Tseed = pdoc.GetFirstItem( "WeaForecastTable" )

Call rt.appendrtitem(Tseed)

Set rtnav = rt.CreateNavigator

If Not rtnav.FindFirstElement(RTELEM_TYPE_TABLE) Then

Messagebox "Body item does not contain a table,",, "Error"

Exit Sub

End If

Set rtt = rtnav.GetElement

Call rtt.AddRow(dc.count-1)

Call rtnav.FindfirstElement(RTELEM_TYPE_TABLECELL)

For t=1 To 8 '这里设定跳过的表头的列数