Sending an email from Access using a different Outlook email address

Question

I am trying to send a fax from Outlook using a different Outlook address than mine which is the one that it defaults to. Below is my code.

Thank you.

Private Sub FaxDoctor() ' Faxes the doctor with the letter On Error GoTo Error_Handler Dim fso

Dim olApp As Object

' Dim olApp As Outlook.Application

Dim olNS As Outlook.NameSpace
Dim olfolder As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists("\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf") Then ' If the filename is found
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olfolder = olNS.GetDefaultFolder(olFolderInbox)
    Set olMailItem = olfolder.Items.Add("IPM.Note")
    olMailItem.display
    With olMailItem
        .Subject = " "
        .To = "[fax:" & "Dr. " & Me.[Prescriber First Name] & " " & Me.[Prescriber Last Name] & "@" & 1 & Me!Fax & "]" ' Must be formatted exactly to be sent as a fax
        '.Body = "This is the body text for the fax cover page" ' Inserts the body text
        .Attachments.Add "\\pna434h0360\PharmServ\Output\" & Me!ID & ".pdf" ' attaches the letter to the e-mail/fax
        '.SendUsingAccount = olNS.Accounts.Item(2) 'Try this to change email accounts
    End With

    Set olMailItem = Nothing
    Set olfolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
Else
    GoTo Error_Handler
End If

Exit_Procedure: On Error Resume Next Exit Sub Error_Handler: MsgBox ("No Letter found" & vbCrLf & "If you are certain the letter is saved with the correct filename then close down Outlook and try again.") ' This often crashes because the letter is not found or because outlook has crashed. In which case every Outlook process should be closed and Outlook should be restarted. Exit Sub End Sub

Answer 1

You can change the outlook account by using the 'SendUsingAccount' property of the mail item. This needs to be set to an account object.

You can set the account for a given name using something like this where 'AccountName' is the address you're sending from.

Dim olAcc as Outlook.Account

For Each olAcc In Outlook.Session.Accounts
    If outAcc.UserName = 'AccountName' Then
        olMailItem.SendUsingAccount = outAcc
        Exit For
    End If
Next

Answer 2

Try using ".SendOnBehalfOfName"

I found this function online, so just follow its lead:

Function SendEmail()

Dim Application As Outlook.Application
Dim NameSpace As Outlook.NameSpace

Dim SafeItem, oItem ' Redemption

Set Application = CreateObject("Outlook.Application")

Set NameSpace = Application.GetNamespace("MAPI")

NameSpace.Logon


Set SafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem
Set oItem = Application.CreateItem(0) 'Create a new message
SafeItem.Item = oItem 'set Item property
SafeItem.Recipients.Add "customer@ispprovider.com"
SafeItem.Recipients.ResolveAll
SafeItem.Subject = "Testing Redemption"
SafeItem.SendOnBehalfOfName = "Invoices@companyname.com"

SafeItem.Send

End Function