Choose which Outlook account to send email

Ehab1511

New Member
Joined
May 21, 2019
Messages
3
Hi,

Please can you help to handle below code to let me choose which account will be used to send email as I have two in my PC.

VBA Code:
Option Explicit

Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
 
    Dim objOutlook As Object 'Outlook.Application
    Dim objOutlookMsg As Object 'Outlook.MailItem
    Dim objOutlookRecip As Object 'Outlook.Recipient
    Dim objOutlookAttach As Object 'Outlook.Attachment
    Dim lngLoop As Long
    Dim strSignature As String
 
    If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
        MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
        Exit Function
    End If

    'Create the Outlook session.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
    Err.Clear: On Error GoTo -1: On Error GoTo 0
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
    End If
 
    'Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(0)

    With objOutlookMsg
    
        'Add the To recipient(s) to the message.
        For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
            If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
                objOutlookRecip.Type = 1 'olTO
            End If
        Next lngLoop
     
        'Add the CC recipient(s) to the message.
        For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
            If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
                objOutlookRecip.Type = 2 'olCC
            End If
        Next lngLoop
     
        'Add the BCC recipient(s) to the message.
        For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
            If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
                Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
                objOutlookRecip.Type = 3 'olBCC
            End If
        Next lngLoop
     
        'Set the Subject, Body, and Importance of the message.
        If strSubject = "" Then
            strSubject = "This is an Automation test with Microsoft Outlook"
        End If
        .Subject = strSubject
        If strMessage = "" Then
            strMessage = "This is the body of the message." & vbCrLf & vbCrLf
        End If
        .Importance = 2 'High importance
        If Not strMessage = "" Then
            .Body = strMessage & vbCrLf & vbCrLf
        End If
    
        If Not rngToCopy Is Nothing Then
            .HTMLBody = .Body & RangetoHTML(rngToCopy)
        End If
     
        'Add attachments to the message.
        If Not strAttachmentPath = "" Then
            For lngLoop = LBound(Split(strAttachmentPath, ";")) To UBound(Split(strAttachmentPath, ";"))
                If Len(Dir(Trim(Split(strAttachmentPath, ";")(lngLoop)))) <> 0 Then
                    Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, ";")(lngLoop)))
                Else
                    MsgBox "Unable to find the specified attachment. Sending mail anyway."
                End If
            Next lngLoop
        End If
    
        If blnSignature Then
            'Win XP
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
            strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
            If Dir(strSignature) = "" Then
            'Win 7
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
                strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
            End If
        End If
     
        If Dir(strSignature) <> "" Then
            strSignature = GetBoiler(strSignature)
        Else
            strSignature = ""
        End If
    
        'MsgBox .htmlbody
        .HTMLBody = .HTMLBody & strSignature
        
        'Resolve each Recipient's name.
        For Each objOutlookRecip In .Recipients
            objOutlookRecip.Resolve
        Next
     
        'Should we display the message before sending?
        If blnShowEmailBodyWithoutSending Then
            .Display
        Else
            .Save
            .Send
        End If
    End With
 
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookRecip = Nothing
 
End Function

Function RangetoHTML(rng As Range)

    'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim strTempFile As String
    Dim wbkTemp As Workbook

    strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a workbook to receive the data.
    rng.Copy
    Set wbkTemp = Workbooks.Add(1)
    With wbkTemp.Sheets(1)
        With .Cells(1)
            .PasteSpecial Paste:=8
            .PasteSpecial xlPasteValues, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            .Select
        End With
        Application.CutCopyMode = False
        On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
        Err.Clear: On Error GoTo 0
    End With

    'Publish the sheet to an .htm file.
    With wbkTemp.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=strTempFile, _
         Sheet:=wbkTemp.Sheets(1).Name, _
         Source:=wbkTemp.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the .htm file into the RangetoHTML subroutine.
    RangetoHTML = GetBoiler(strTempFile)
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close wbkTemp
    wbkTemp.Close savechanges:=False

    'Delete the htm file.
    Kill strTempFile

    Set wbkTemp = Nothing

End Function

Function GetBoiler(ByVal strFile As String) As String

    'May not be supported in MAC
    Dim objFSO As Object
    Dim objTextStream As Object
    On Error Resume Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
    GetBoiler = objTextStream.ReadAll
    objTextStream.Close

    Set objFSO = Nothing
    Set objTextStream = Nothing

End Function


I try to updated attached macro by below code but it is not working.

Dim Account As Outlook.Account

For Each Account In objOutlook.Session.Accounts

'Debug.Print Account.DisplayName
If Account.DisplayName = "Insert account name" Then

objOutlookMsg.SendUsingAccount = Account

End If
Next

Thanks;
Ehab
 
Last edited by a moderator:

Some videos you may like

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,745
Office Version
  1. 2016
  2. 2010
  3. 2007
Platform
  1. Windows
Hi and welcome to MrExcel!

Try these code lines:
Set objOutlookMsg.SendUsingAccount = Account
Exit For
 
Last edited:

Ehab1511

New Member
Joined
May 21, 2019
Messages
3
Hi ZVI
Hi and welcome to MrExcel!

Try these code lines:
Set objOutlookMsg.SendUsingAccount = Account
Exit For
Hi ZVI,

How kind you are to help me. Thank you very much.
I face an issue when I use this lines, Please can you add it in the code and send me the full code to see what's the mistake I did it.

That's a huge help - thanks!

Thanks;
Ehab
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,745
Office Version
  1. 2016
  2. 2010
  3. 2007
Platform
  1. Windows
Insert code into the Function SendMessage after code line: With objOutlookMsg , like this:
VBA Code:
Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
 
    ' ... The code as is ...

    With objOutlookMsg
    
        ' --> Start of the inserted code
        ' Set the account to send from.
        ' Use the account number (2 is used in the below line) or the name of the account like: "AccountName@domainName.com"
        Set .SendUsingAccount = objOutlook.Session.Accounts.Item(2)
        '<-- End of the inserted code
        
        'Add the To recipient(s) to the message.
        
        ' ...the code as is ...
        
    End With
 
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookRecip = Nothing
 
End Function
 

Ehab1511

New Member
Joined
May 21, 2019
Messages
3
Hi ZVI,

Wow! Thank you so much. This is awesome. This will save me so much time.

Thanks;
Ehab
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,146
Office Version
  1. 365
Platform
  1. Windows
@Ehab1511
For future reference while we do allow Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules). This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered elsewhere.

Cross posted Choose which Outlook account to send email
 

Watch MrExcel Video

Forum statistics

Threads
1,114,071
Messages
5,545,817
Members
410,708
Latest member
SanTrapGamer
Top