Subject: RE: Collecting Header Info to Send to 3rd Party
Hi Melissa,
I don’t know what might be the cause but this one is working:
Create an action button in the inbox folder.
Sub Click(Source As Button)
'testing
Dim s As New notessession
Dim doc As NotesDocument
Dim c As notesdocumentcollection
Dim DeliveryInformation As String
Dim posteddate As NotesDateTime
Dim received As String
Dim mimetrack As String
Dim messageid As String
Dim mailer As String
Dim mimeversion As String
Dim deliveredto As String
Dim cr As String
cr = Chr(13)+Chr(10)
Set db=s.currentdatabase
Set c=db.UnprocessedDocuments
fname="c:\temp\notessmtpheader.txt"
If c.count=0 Then
Msgbox "Select a document first", MB_OK
Exit Sub
End If
For jj = 1 To c.Count
Set doc = c.GetNthDocument( jj )
If doc.HasItem( "Received") Then
returnpath = getitem("from",doc)
posted = getitem("posteddate",doc)
precedence = GetItem("Precedence",doc)
deliveredto = GetItem("Delivered_To",doc)
received = GetItem( "Received",doc)
mimetrack = GetItem( "$MIMETrack", doc)
messageid = GetItem( "$MessageID", doc)
mailer = GetItem( "$Mailer", doc)
mimeversion = GetItem( "MIME_Version", doc)
body = GetItem("Body",doc)
subject = GetItem ("Subject",doc)
DeliveryInformation =">From "+returnpath+" "+posted+cr+_
received+_
"Subject: "+ subject + cr +_
"MIME-Track: "+mimetrack +cr+ _
"Date: " + posted + cr +_
"Message-ID:" + messageid + cr+"X-Mailer:"+ mailer + cr+_
"Mime-Version:"+ mimeversion + cr + cr +_
body
Open fname For Output As #1
Print #1, deliveryinformation
Close #1
' cmd="notepad.exe " & fname
' i%=Shell(cmd, 1)
End If
Call SendFile(doc,fname)
Next jj
End Sub
Function GetItem( FieldName As String, doc As NotesDocument) As String
Dim item As NotesItem
Dim cr As String
Dim Contents As String
Dim receivedSplit As Variant
Dim sep As String
cr = Chr(13)+Chr(10)
sep=String(10," “)
While doc.HasItem( FieldName)
Set item = doc.GetFirstItem( FieldName)
If Lcase(item.name)=“received” Then
If Instr(item.text,Chr(34)) Then
tmp=”"
For kk=1 To Len(item.text)
c=Mid(item.text,kk,1)
If c=Chr(34) Then c=“'”
tmp=tmp & c
Next
Else
tmp=“Received: “+item.text
End If
e={@implode(@explode(”} & tmp & {”;“;”);@newline)}
receivedSplit = Evaluate(e,doc)
f={@replacesubstring(@trim("} & receivedSplit(0) &
{“);@char(9):”} & sep & {“;” ")}
g=Evaluate(f)
contents=Contents + g(0) + cr
Else
Contents = Contents + item.Text
End If
Call item.Remove
Wend
GetItem$ = Contents
End Function
Sub SendFile(doc,file)
Dim session As NotesSession
Dim Courrier As NotesDocument
Dim Item As NotesRichTextItem
Set session = New NotesSession
Set Courrier = New NotesDocument (Session.CurrentDatabase)
Set Item = New NotesRichTextItem(Courrier , "Body")
Courrier.SendTo = "Your Name here"
Courrier.Form = "Memo"
Set object = item.EmbedObject ( EMBED_ATTACHMENT, "", file)
Courrier.Subject = "File SPAM"
Call Courrier.send(False)
Exit Sub
End Sub