The below code works in our current environment (Win2000, Access 2000, Notes Client 5.0.9a).
We are moving to WinXP, Access 2003, Notes 6.5. The below code works, except that it does not include the body of the email.
Any ideas?
Function fSendEmail(strFileName, strPosterLoc) As Boolean
'In: strFilename: File to attach to email
’ strPosterLoc: Location to Email for
’
'Out: Sends an email via Lotus Notes
’ Succsess = True/False
'Maint Log:
’
'Who When What
'— ---- ----
'WJSchan 2/2/04 - Added:
’ notesDoc.Principal = strSharedMailBox
’ notesDoc.ReplyTo = strSharedMailBox
’ notesDoc.SaveMessageOnSend = True
’
’ So that the email would look like it came from ‘Trust Financial Controls-St Paul’,
’ and be saved in the sent folder.
’
’ - Changed email so that the Shared Email Box was not cc:'d
’
’ - Changed subject line to → Please “Reply with History”
’ from → Please “Reply to Trust Financial Controls-St Paul”
’
’
'WJSchan 2/10/04 - Added Users ID to the bottom of the email body, so for research purposes
’ we would know who the email came from.
’
’ In the sent folder of TFC-SP it will always show from the user who is looking
’ at the email.
'On Error GoTo fSendEmail_ErrHandle
Dim db As Database, rsContacts, notesSess As Object
Dim notesDB As Object, notesDoc As Object, notesItem As Object
Dim varEmailAddress As Variant
Dim strBody As String, EmbedMyfile As Object, i As Integer, intCount As Integer
Dim strRecipient() As String, intPos As Integer
Dim strSharedMailBox As String
Const conQuote = “”“”
Const conDeptName = “Trust Financial Controls - St. Paul”
Const conStreetAddr = “60 Livingston Avenue”
Const conMailStation = “Mailstation: EP-MN-WN3M”
Const conCityStateZip = “St. Paul, MN 55107”
Const conFaxNumber = “(651) 767-9222”
Set db = CurrentDb()
Set rsContacts = db.OpenRecordset(“SELECT * FROM qry_Contacts_To_Email WHERE (((Owner) Like ‘" & strPosterLoc & "’));”)
If rsContacts.RecordCount = 0 Then
Call MsgBox("There are no items to email!", vbOKOnly + vbExclamation, "No items qualify")
fSendEmail = False
GoTo fSendEmail_Exit
End If
'Start lotus - if lotus is not already open the user will need to enter a password
Set notesSess = CreateObject(“Notes.Notessession”)
'Mail Settings:
Set notesDB = notesSess.GetDatabase(“**********", "”) 'Taken out for LDD Posting
rsContacts.MoveFirst
Do While Not rsContacts.EOF
'These mail settings must be re-created everytime the a new mail is sent,
'so that the SaveMessageOnSend option works correctly.
'They must be set to nothing at the bottom of the loop as well:
Set notesDoc = notesDB.CreateDocument
Set notesItem = notesDoc.CreateRichTextItem("BODY")
Set EmbedMyfile = notesItem.EMBEDOBJECT(1454, "", strFileName, "") 'Attachment
varEmailAddress = rsContacts("Contacts")
If rsContacts("Contact_Unknown") Then
notesDoc.Subject = "Aged Exceptions - " & conQuote & "UNKNOWN Contact" & conQuote
Else
notesDoc.Subject = "Aged Exceptions (Location: '" & rsContacts("Owner") _
& "') - Action Required -- Please " & conQuote & "Reply with History" & conQuote
End If
strBody = "We have determined that poster location '" & rsContacts("Owner") & "' "
strBody = strBody & "has " & rsContacts("Items") & " exception(s) that will be aged "
strBody = strBody & rsContacts("AgeCriteria") & " days or older as of Friday, "
strBody = strBody & rsContacts("AgeAsOf") & ". The attached Excel Spreadsheet is a list of "
strBody = strBody & "all aged items in accounts reconciled by Trust Financial Controls - St. Paul. "
strBody = strBody & "You can find your items by sorting on Poster Location or by using the filter "
strBody = strBody & "for your poster location." & ddm_DoubleSpace
strBody = strBody & "Our goal is to clear ALL exceptions prior to day 15, and those which have "
strBody = strBody & "surpassed 15 days are escalated as needed to management." & ddm_DoubleSpace
strBody = strBody & "Please respond within 2 business days with a status update as to when the items "
strBody = strBody & "will clear." & ddm_DoubleSpace
strBody = strBody & "Thank you for your assistance." & ddm_DoubleSpace
strBody = strBody & "TFCSP Reference: " & GetUserName() & ddm_DoubleSpace
strBody = strBody & "* * * * * * * * * * * * * *" & vbCrLf
strBody = strBody & conDeptName & vbCrLf
strBody = strBody & conStreetAddr & vbCrLf
strBody = strBody & conMailStation & vbCrLf
strBody = strBody & conCityStateZip & vbCrLf
strBody = strBody & "Fax " & conFaxNumber
notesDoc.body = strBody
'Find the number of Recipients -- You must ReDim the Array with only the number of Recipients!!!
intCount = 1 'Assume there is one
For i = 1 To Len(varEmailAddress)
If Mid(varEmailAddress, i, 1) = "," Then intCount = intCount + 1
Next i
intCount = intCount - 1 'Arrays start @ Zero
ReDim strRecipient(intCount) As String
If intCount > 0 Then
For i = 0 To intCount
If i < intCount Then
intPos = InStr(1, varEmailAddress, ",")
strRecipient(i) = Mid(varEmailAddress, 1, intPos - 1)
varEmailAddress = Mid(varEmailAddress, intPos + 2, Len(varEmailAddress))
ElseIf i = intCount Then
strRecipient(i) = Mid(varEmailAddress, 1, Len(varEmailAddress))
End If
Next i
ElseIf intCount = 0 Then 'There was only one Recipient
strRecipient(intCount) = varEmailAddress
End If
notesDoc.SendTo = strRecipient
'notesDoc.CopyTo = strUser 'Use for cc
'notesDoc.BlindCopyTo = strUser 'Use for bcc
strSharedMailBox = rsContacts("SharedMailBox")
notesDoc.Principal = strSharedMailBox
notesDoc.ReplyTo = strSharedMailBox
notesDoc.SaveMessageOnSend = True
Call notesDoc.Send(False) 'Send the email!
Set notesItem = Nothing
Set notesDoc = Nothing
Set EmbedMyfile = Nothing
rsContacts.MoveNext
Loop
'Succsess
fSendEmail = True
fSendEmail_Exit:
On Error Resume Next
rsContacts.Close
Set rsContacts = Nothing
Set notesItem = Nothing
Set notesDoc = Nothing
Set EmbedMyfile = Nothing
Exit Function
fSendEmail_ErrHandle:
Select Case Err.Number
Case 7294 'Email Recipient not valid
Call MsgBox("Email to Poster Location '" & rsContacts("Owner") & "' failed!" & ddm_DoubleSpace _
& "Re: '" & varEmailAddress & "' is not a valid email address." & ddm_DoubleSpace _
& "Have the work co-ordinator fix this poster location, and re-send the email " _
& "to just this location. All other emails were sent successfully.", vbCritical + vbOKOnly, _
"Error sending email ...")
UpdateActionLog ("Email to poster location '" & rsContacts("Owner") & "'failed. " _
& "Email address: '" & varEmailAddress & "' is not valid")
Resume Next
Case Else
fSendEmail = False
Call CommonErrorMsg("Command: " & "fSendEmail", Err.Number, Err.HelpFile, Err.HelpContext)
End Select
End Function
