SOLVED: Cannot set Outlook SendUsingAccount
A client wants to e-mail newsletters using a non-default Outlook account. The code below does everything the client needs except setting the SendUsingAccount. In debug I can see that the correct account is assigned, yet all of my testing results in e-mails where the From line is the default account. The test setup uses my own isolated SMTP server, so when I look at the e-mails sent the sender is the default account. The default account's Sent folder shows the sent mail, which is not what we want. What am I missing?
A client wants to e-mail newsletters using a non-default Outlook account. The code below does everything the client needs except setting the SendUsingAccount. In debug I can see that the correct account is assigned, yet all of my testing results in e-mails where the From line is the default account. The test setup uses my own isolated SMTP server, so when I look at the e-mails sent the sender is the default account. The default account's Sent folder shows the sent mail, which is not what we want. What am I missing?
Code:
Sub prepEmail()
Dim frm As Form, startDate As Date, endDate As Date
Dim rs As DAO.Recordset, strSQL As String, intNewsLetter As Integer
Dim rsEmail As DAO.Recordset, rsNewsletters As DAO.Recordset
Dim OlApp As Object, ol As Object
Dim olMail As Object, olAcct, olAcctTemp
Dim olMailItem, strRecip As String, strLocation As String, strBody As String, strSubject As String
Dim success As Boolean, total As Long
Dim dicSuccess, dicItem, strMsg As String, strKey As String, strValue As String
Dim bDebug As Boolean
bDebug = True
DoCmd.SetWarnings False
On Error Resume Next
Set OlApp = GetObject(, "Outlook.Application")
If OlApp Is Nothing Then
Set OlApp = CreateObject("Outlook.Application")
End If
Set ol = OlApp.Parent
Dim Session As Object
Set Session = OlApp.GetNamespace("MAPI")
Session.Logon
Set olAcct = ol.Account
Set olMail = OlApp.CreateItem(olMailItem)
Set dicSuccess = CreateObject("Scripting.Dictionary")
On Error GoTo prepEmail_Error
Set rsEmail = CurrentDb.OpenRecordset("tblEmailSettings")
'get items to be e-mailed
strSQL = "SELECT action_items.action, tblNewsletters.location, tblNewsletters.body, action_items.enabled, " & _
"action_items.[e-mail], action_items.attach, tblNewsletters.task_id " & _
"FROM action_items LEFT JOIN tblNewsletters ON action_items.action_id = tblNewsletters.task_id " & _
"WHERE action_items.enabled=True AND action_items.[e-mail]=True"
Set rsNewsletters = CurrentDb.OpenRecordset(strSQL)
'testing date criteria
If bDebug Then
startDate = "5/22/2013"
endDate = "5/29/2013"
Else
Set frm = Forms("frmFYSelector")
startDate = frm!txtFYStart
endDate = frm!txtFYEnd
End If
DoCmd.Close acForm, "frmFYSelector"
If Not validateEmailSettings(rsEmail, rsNewsletters) Then
Exit Sub
End If
strSubject = rsEmail("subject")
For Each olAcctTemp In OlApp.Session.Accounts
If olAcctTemp.SmtpAddress = rsEmail("recipient") Then
Set olAcct = olAcctTemp
End If
Next
rsNewsletters.MoveFirst
'one e-mail per newsletter
Do While Not rsNewsletters.EOF
'initialize e-mail
With rsNewsletters
Set olMail = OlApp.CreateItem(olMailItem)
strRecip = ""
strLocation = Nz(!location, "")
strBody = !Body
intNewsLetter = !task_id
End With
'build bcc list
strSQL = "SELECT mothers.Email, checklist.checklist_id " & _
"FROM checklist INNER JOIN (mothers INNER JOIN tblCases ON mothers.case_id = tblCases.case_id) ON checklist.case_id = tblCases.case_id " & _
"WHERE checklist.action_id = " & intNewsLetter & _
" And checklist.completed = False And checklist.due >= #" & _
startDate & "# And checklist.due <= #" & endDate & "# And mothers.email Is Not Null"
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount > 0 Then
rs.MoveLast
rs.MoveFirst
strKey = rsNewsletters("action")
strValue = rs.RecordCount
total = total + strValue
dicSuccess.Add Key:=strKey, Item:=strValue
Do While Not rs.EOF
strRecip = strRecip & "; " & rs("email")
rs.MoveNext
Loop
With olMail
.SendUsingAccount = olAcct
.BCC = Right(strRecip, Len(strRecip) - 2)
.BodyFormat = 2
.Body = strBody
.sender = rsEmail("recipient")
.subject = strSubject
If strLocation <> "" Then
.attachments.Add strLocation
End If
.Recipients.Add rsEmail("recipient")
End With
If bDebug Then
'force success = true to test checklist completions
olMail.Display
success = True
Else
success = olMail.Send
End If
'on success mark task completed for each bcc recipient
If success Then
rs.MoveFirst
Do While Not rs.EOF
strSQL = "update checklist set completed = true where checklist_id = " & rs("checklist_id")
DoCmd.RunSQL strSQL
rs.MoveNext
Loop
Else
MsgBox strKey & " e-mail failed (" & strValue & " recipients)", vbCritical, "E-mail failures"
End If
Set olMail = Nothing
Set rs = Nothing
End If
rsNewsletters.MoveNext
Loop
Set rsEmail = Nothing
Set rsNewsletters = Nothing
'build success message on success
If success Then
For Each dicItem In dicSuccess
strMsg = strMsg & dicItem & ": " & dicSuccess(dicItem) & vbCr & vbLf
Next
MsgBox strMsg, vbInformation, "E-mail items & quantity"
End If
'alert if no e-mails sent
If total = 0 Then
MsgBox "No e-mails were sent", vbInformation, "E-mail success"
End If
'clean up after test run
'If bDebug Then
' CurrentDb.Execute "qryEmailUpdateDebug"
'End If
'
DoCmd.SetWarnings True
On Error GoTo 0
Exit Sub
prepEmail_Error:
MsgBox "Error " & Err.number & " (" & Err.Description & " in procedure prepEmail of Module emailer)"
End Sub
Last edited:
