(Declarations:)


Const TargetEmail = "XXX@xxx.com"
Dim db As notesdatabase
Dim session As NotesSession

(Initialize:)

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


(ProcessEmail:)

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


(ParseAddr:)

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