Subject: copy mail agent
I have a foldered called “Auto File” in my mail that I can drag documents from my Inbox to and it will move the documents to a “shared database”. You put the code in the “Addtofolder” event in the folder that you will be dragging the documents in. Below is the code. It is probably more code than you need, but you’ll get the idea.:
Sub Queryaddtofolder(Source As Notesuiview, Target As Variant, Continue As Variant)
Dim w As New notesuiworkspace
Dim s As New NotesSession
If Target = "Auto File" Then
Dim db As NOtesDatabase
Dim corrDB As NotesDatabase
Dim contview As NotesView
Dim dc As NotesDocumentCollection
Dim ndc As NotesDocumentCollection
Dim doc As NotesDocument
Dim ndoc As NotesDocument
Dim contdoc As NotesDocument
Dim corrdoc As NotesDocument
Dim contactdoc As notesdocument
Dim item As notesitem
Dim extr As String
Dim emailview As NotesView
Dim newdoc As NotesDocument
Dim spamdoc As NotesDocument
Dim disposition As String
Dim SPAMDB As NotesDatabase
Dim domainview As NotesView
Dim uidoc As notesdocument
Dim choice As String
Dim choices(0 To 1) As String
Set db = s.CurrentDatabase
Set corrDB = s.GetDatabase(db.Server,"SubDir\Correspondence.nsf")
Set contDB = s.GetDatabase(db.Server,"SubDir\Contacts.nsf")
Set contview = contDB.GetView("(ContactByEmail)")
Set dc = source.Documents
Set doc = dc.GetFirstDocument
Do While Not (doc Is Nothing)
If doc.HasItem("DeliveredDate") And Not doc.DeliveredDate(0) = "" Then
disposition = "Memo In"
Elseif Not doc.PostedDate(0) = "" Then
disposition = "Sent"
'Draft and Other will be removed from the collection, thus disregarded
Elseif doc.Form(0) = "Memo" Then
disposition = "Draft"
Call dc.DeleteDocument(doc)
Goto Nextdoc
Else
disposition = "Other"
Call dc.DeleteDocument(doc)
Goto Nextdoc
End If
Dim FromName As New NotesName(doc.From(0))
Dim SendToName As New NotesName(doc.SendTo(0))
Dim CopyToName As New NotesName(doc.CopyTo(0))
Dim BlindCopyToName As New NotesName(doc.BlindCopyTo(0))
If Strleft(doc.CopyTo(0),"=") = "CN" Then
theCopyTo = CopyToName.common
Else
theCopyTo = CopyToName.Addr821
End If
If Strleft(doc.BlindCopyTo(0),"=") = "CN" Then
theBlindCopyTo = BlindCopyToName.common
Else
theBlindCopyTo = BlindCopyToName.Addr821
End If
If disposition = "Memo In" Then
If doc.HasItem("SMTPOriginator") And Not doc.SMTPOriginator(0) = "" Then
key$ = doc.SMTPOriginator(0)
Elseif doc.HasItem("INetFrom") And Not doc.INetFrom(0) = "" Then
key$ = doc.INetFrom(0)
Else
If Strleft(doc.From(0),"=") = "CN" Then
key$ = FromName.common
Set contview = contDB.GetView("(ContactByFullCommonName)")
Else
key$ = FromName.Addr821
End If
End If
Else
If Strleft(doc.SendTo(0),"=") = "CN" Then
key$ = SendToName.common
Set contview = contDB.GetView("(ContactByFullCommonName)")
Else
If Isnull(SendToName.Addr821) Or Isempty(SendToName.Addr821) Or SendToName.Addr821 = "" Then
key$ = SendToName.Common
Set contview = contDB.GetView("(ContactByFullCommonName)")
Else
key$ = SendToName.Addr821
End If
End If
End If
Set contdoc = contview.GetDocumentByKey(key$)
Set corrdoc = corrDB.CreateDocument
Call doc.CopyAllItems(corrdoc,True)
corrdoc.Form = "Correspondence"
corrdoc.FormType = "MemoOut" ' All will now be using this form
corrdoc.CC_Email = theCopyTo
corrdoc.BCC_Email = theBlindCopyTo
If disposition = "Memo In" Then
corrdoc.date_corr = doc.DeliveredDate(0)
corrdoc.Status = "Received"
corrdoc.queryname = "Memo In - " & doc.Subject(0) & " - " & Cstr(doc.DeliveredDate(0))
Else
corrdoc.date_corr = doc.PostedDate(0)
corrdoc.Status = "Sent"
corrdoc.queryname = "Memo Out - " & doc.Subject(0) & " - " & Cstr(doc.PostedDate(0))
End If
If Not (contdoc Is Nothing) Then
corrdoc.contact_name = contdoc.contact_name
corrdoc.fullcommonname = contdoc.fullcommonname
corrdoc.CompanyName = contdoc.CompanyName
corrdoc.OfficePhoneNumber = contdoc.OfficePhoneNumber(0)
corrdoc.ContactUNID = contdoc.docID(0)
corrdoc.IT_ID = contdoc.IT_ID
Set item = New notesitem(corrdoc,"Authors","*",AUTHORS)
Else
choices(0) = "1. Create a new contact entry and then file"
choices(1) = "2. Select an existing contact to file message under"
choice = w.Prompt(PROMPT_OKCANCELLIST,"Contact not found",key$ & " not found in Contacts database. What would you like to do?",choices(0),choices)
If Isempty(choice) Then
Continue = False
Exit Sub
End If
Select Case Left(choice,1)
Case "1"
Set contactdoc = db.CreateDocument
contactdoc.form = "Person"
contactdoc.mailaddress = key$
'attempt to figure out name
If Instr(doc.From(0),"<") > 0 Then
If Instr(doc.From(0),",") > 0 Then
tmpName = Trim(Strleft(doc.From(0),"<"))
tmpFName = Mid(Strright(tmpName," "),1,Len(Strright(tmpName," "))-1)
tmpLName = Mid(Strleft(tmpName,","),2)
contactdoc.FirstName = tmpFName
contactdoc.LastName = tmpLName
Else
tmpName = Trim(Strleft(doc.From(0),"<"))
tmpFName = Mid(Strleft(tmpName," "),2)
tmpLName = Mid(Strright(tmpName," "),1,Len(Strright(tmpName," "))-1)
contactdoc.FirstName = tmpFName
contactdoc.LastName = tmpLName
End If
End If
If w.dialogbox("Person",True,True,False,False,False,False,"New Contact",contactdoc) Then
Set contdoc = contDB.createdocument
contdoc.form = "Person"
If contactdoc.LastName(0) = "" Then
If contactdoc.FirstName(0) = "" Then
contdoc.contact_name = ""
Else
contdoc.contact_name = contactdoc.FirstName(0)
End If
Else
If contactdoc.FirstName(0) = "" Then
contdoc.contact_name = contactdoc.LastName(0)
Else
contdoc.contact_name = contactdoc.LastName(0) & ", " & contactdoc.FirstName(0)
End If
End If
Call contactdoc.CopyAllItems(contdoc,True)
Call contdoc.Save(True,False)
contdoc.IT_ID = contdoc.UniversalID
contdoc.DocID = contdoc.UniversalID
Call contdoc.Save(True,False)
corrdoc.contact_name = contdoc.contact_name
corrdoc.fullcommonname = contdoc.fullcommonname
corrdoc.CompanyName = contdoc.CompanyName
corrdoc.OfficePhoneNumber = contdoc.OfficePhoneNumber(0)
corrdoc.ContactUNID = contdoc.docID(0)
corrdoc.IT_ID = contdoc.IT_ID
Set item = New notesitem(corrdoc,"Authors","*",AUTHORS)
End If
Case "2"
Set ndc = w.PickListCollection( 3, False, db.Server, contDB.filepath, "FullNameLast", "Select Contact(s)", "Select the contact(s) to associate this e-mail with.")
If ndc.Count = 0 Then
Continue = False
Exit Sub
End If
Set ndoc = ndc.GetFirstDocument
corrdoc.contact_name = ndoc.contact_name
corrdoc.fullcommonname = ndoc.fullcommonname
corrdoc.CompanyName = ndoc.CompanyName
corrdoc.OfficePhoneNumber = ndoc.OfficePhoneNumber(0)
corrdoc.ContactUNID = ndoc.docID(0)
corrdoc.IT_ID = ndoc.IT_ID
Set item = New notesitem(corrdoc,"Authors","*",AUTHORS)
Case Else
Continue = False
Exit Sub
End Select
End If
If corrdoc.Contact_Name(0) = "" Then
tmpContact_Name = "No Name Available"
Else
tmpContact_Name = corrdoc.Contact_Name(0)
End If
If corrdoc.CompanyName(0) = "" Then
tmpCompanyName = ""
Else
tmpCompanyName = "(" + corrdoc.CompanyName(0)
End If
If corrdoc.OfficePhoneNumber(0) = "" Then
If tmpCompanyName = "" Then
tmpOfficePhoneNumber = ""
Else
tmpOfficePhoneNumber = ")"
End If
Else
If tmpCompanyName = "" Then
tmpOfficePhoneNumber = "(" + corrdoc.OfficePhoneNumber(0) + ")"
Else
tmpOfficePhoneNumber = " " + corrdoc.OfficePhoneNumber(0) + ")"
End If
End If
corrdoc.Contact_List = Trim(tmpContact_Name + tmpCompanyName + tmpOfficePhoneNumber)
corrdoc.History = "Created by " & s.CommonUserName & " on " & Date$ & " " & Time$
Call corrdoc.Save(True,True)
nextdoc:
Set doc = dc.GetNextDocument(doc)
Loop
On Error Goto DocIsOpenError
Call dc.RemoveAll(True)
Call w.ViewRefresh
Continue = False
End If
Exit Sub
DocIsOpenError:
Msgbox "The document has been moved to the Correspondence document but cannot be deleted from your mail because the document is open in another window."
Continue = False
Exit Sub
End Sub