使用Agent转发Lotus邮件

Sub Initialize

Dim doc As NotesDocument

Dim ReturnVal As Boolean

Dim PojistkaMax As Integer

Dim collection As NotesDocumentCollection

Dim Addeditem As NotesItem

Dim CurAgent As NotesAgent

Dim docStatus As Variant

Dim docProcessed As Boolean

Set session = New NotesSession

Set db = session.CurrentDatabase

Set CurAgent = session.CurrentAgent

PojistkaMax = 0

Set collection = db.UnprocessedDocuments

Set doc = collection.GetFirstDocument()

While Not(doc Is Nothing Or PojistkaMax>20)

docStatus=””

docProcessed = False

If (Doc.HasItem(CurAgent.Name & “_done”)) Then

docStatus = Doc.GetItemValue(CurAgent.Name & “_done”)

If (Cstr(docStatus(0))=”1″) Then docProcessed=True

End If

If (docProcessed=False) Then

Call ProcessEmail (doc)

If (Doc.HasItem(CurAgent.Name & “_done”)) Then

Call doc.ReplaceItemValue(CurAgent.Name & “_done”,”1″)

Call doc.Save( True, False, False )

Else

Set Addeditem = doc.AppendItemValue ( CurAgent.Name & “_done”, “1” )

Call doc.Save( True, False, False )

End If

End If

Call session.UpdateProcessedDoc(doc)

Set doc = collection.GetNextDocument(doc)

PojistkaMax = PojistkaMax + 1

Wend

End Sub

Sub ProcessEmail (Mydoc As NotesDocument)

Dim rtnav As NotesRichTextNavigator

Dim MyMssgHeader As String

Dim rtitem As NotesRichTextItem

Dim Maildoc As NotesDocument

Dim senderdomain As String

Dim b As Integer

Dim FromItem As NotesItem

Dim FromName As String

Dim FromEmail As String

Dim FromIDENT As String

Dim FromOrig As String

Dim ItemValue As Variant

Dim m_strForm As String

On Error Goto GenError

If (MyDoc.IsEncrypted) Then Exit Sub

If (myDoc.HasItem(“$KeepPrivate”)) Then

ItemValue = MyDoc.GetItemValue(“$KeepPrivate”)

If (Cstr(ItemValue(0))=”1″) Then Exit Sub

End If

If (Not myDoc.HasItem(“From”)) Then Exit Sub

Set Maildoc = New NotesDocument(db)

Call Mydoc.CopyAllItems( Maildoc, True )

‘        If (Maildoc.HasEmbedded ) Then

Set rtitem = Maildoc.GetFirstItem(“Body”)

‘                  If ( rtitem.Type = RICHTEXT) Then

‘                           If (Not (Isempty(rtitem.EmbeddedObjects))) Then

‘                                    Forall o In rtitem.EmbeddedObjects

‘                                              If ( o.Type = EMBED_ATTACHMENT ) Then

‘                                                       Call o.Remove

‘                                              End If

‘                                    End Forall

‘                           End If

‘                  End If

‘        End If

FromIDENT=””

FromEmail=””

FromName=””

FromOrig=””

If (MailDoc.HasItem(“Principal”)) Then

FromOrig=MailDoc.Principal(0)

Else

FromOrig=MailDoc.From(0)

End If

If (Instr(1,FromOrig,”CN=”)>0 And Instr(1,FromOrig,”OU=”)>0) Then

FromIDENT=FromOrig

Else

Call ParseAddr (FromOrig,FromName, FromEmail)

End If

‘ add by James

If  FromOrig =”Mail Router” Then

Exit Sub

End If

If  FromOrig =”gcsecpoccoord” Then

Exit Sub

End If

If  FromOrig =”LotusQuickr@USSECAVPQUCK02.na.ey.net” Then

Exit Sub

End If

m_strForm = MailDoc.GetItemValue ( “Form”)(0)

If (Strcompare(m_strForm, “Delivery Report”) = 0) Then

Exit Sub

End If

If (Strcompare(m_strForm, “NonDelivery Report”) = 0) Then

Exit Sub

End If

If (Strcompare(m_strForm, “Trace Report”) = 0 ) Then

Exit Sub

End If

If (Strcompare(m_strForm, “Return Receipt”)= 0) Then

Exit Sub

End If

‘ end by James

If (FromIDENT<>””) Then

MailDoc.Principal = FromIDENT

Else

If (FromEmail=””) Then

MailDoc.Principal = FromOrig

Else

MailDoc.Principal = FromName & ” <” & FromEmail & “@NotesDomain” & “>”

MailDoc.INetFrom = FromName & ” <” & FromEmail & “>”

End If

End If

If (Mydoc.HasItem(“ReplyTo”)) Then

Maildoc.ReplyTo = Mydoc.ReplyTo(0)

End If

rtitem.AddNewline(2) ‘ add 2 new lines at the end of Body

rtitem.AppendText(“In the Sent field was: “) ‘ add this text at the end of body, you can modify this part to add this only if in From field is allready something

For b=0 To Ubound(Maildoc.SendTo)

rtitem.AppendText(Maildoc.SendTo(b) + “, “)   ‘add all elements from From field

Next

rtitem.AddNewline(2) ‘ add 2 new lines at the end of Body

rtitem.AppendText(“In the CC field was: “) ‘ add this text at the end of body, you can modify this part to add this only if in CC field is allready something

For b=0 To Ubound(Maildoc.CopyTo)

rtitem.AppendText(Maildoc.CopyTo(b) + “, “)   ‘add all elements from CC field

Next

rtitem.AddNewline(2) ‘ add 2 new lines at the end of Body

rtitem.AppendText(“In the BCC field was: “) ‘ add this text at the end of body, you can modify this part to add this only if in CC field is allready something

For b=0 To Ubound(Maildoc.BlindCopyTo)

rtitem.AppendText(Maildoc.BlindCopyTo(b) + “, “)   ‘add all elements from CC field

Next

If (Maildoc.HasItem(“CopyTo”)) Then

Maildoc.CopyTo = “”

End If

If (Maildoc.HasItem(“BlindCopyTo”)) Then

Maildoc.BlindCopyTo = “”

End If

Maildoc.SendTo = TargetEmail

Call Maildoc.Send(False)

Set Maildoc = Nothing

Exit Sub

GenError:

Set Maildoc=Nothing

Set Maildoc = New NotesDocument(db)

With Maildoc

.Subject=”An error occured while parsing”

.SendTo = TargetEmail

.Body=”An error occured while parsing message ”         & Mydoc.Subject(0) & “, from: ” & Mydoc.From(0) & “….Err msg: ” & Error$

Call .Send(False)

End With

Set Maildoc=Nothing

Exit Sub

End Sub

Sub ParseAddr (ParseWhat As String, Part1 As String,Part2 As String)

Dim i As Integer

Dim i2 As Integer

i=Instr(1,ParseWhat,”<“)

i2=Instr(i,ParseWhat,”>”)

If (i>=i2) Then

Exit Sub

End If

If (i=0) Then i=0

If (i2=0) Then i2=Len(ParseWhat)+1

If (i>=3) Then

Part1=Mid(ParseWhat,1,i-2)

End If

Part2=Mid(ParseWhat,i+1,i2-i-1)

If (Instr(1,Part2,”@”)=0) Then

Part2=””

End If

End Sub