Cannot set Outlook SendUsingAccount

geoB

Registered User.
Local time
Today, 16:57
Joined
Oct 10, 2008
Messages
68
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?
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:
Declare olAcct as object. Right now it is declared as variant.

Code:
Set OlApp = GetObject(, "Outlook.Application") If OlApp Is Nothing Then     Set OlApp = CreateObject("Outlook.Application") End If
The above is redundant code, apparently inserted by soem guru and copied and copied and copied ... Replace it by :

Code:
 Set OlApp = CreateObject("Outlook.Application")
which is enough, because the CreateObject call Gets an Ouitlook app if it is open, or creates the object if not. It namely "knows" that onlyu one instance of Outlook can run.

Try
set .SendUsingAccount = olAcct

Using On Error Resume next is recommended if you know what you are doing, and if the bit of code cannot possibly fail This does not apply to your code! Also, debugging code with error handling enabled, and warnings disabled is silly. Further, your
DoCmd.SetWarnings True will never get executed if you indeed have an error "handled" by your error handler.
 
Last edited:
Thanks for the reply.
Set OlApp = CreateObject("Outlook.Application")
This is where I started. I took some old guru's advice and tried that for no change. It will shortly disappear.
set .SendUsingAccount = olAcct
This I will try. SWMBO calls.

Will report when back. g
 
Code:
 Set OlApp = CreateObject("Outlook.Application")
is indeed the solution!!!

Also, for those who may foolishly copy my code, I needed to delete the line
Code:
Set olAcct = ol.Account
because it was not possible to set an object to "Outlook" itself.

There is joy in Mudville tonight!

George
 

Users who are viewing this thread

Back
Top Bottom