VBA - Send An Email Using Account That I Want

fiberboysa

Board Regular
Joined
Apr 25, 2012
Messages
89
Office Version
2019
Platform
Windows
Hi Dear All,
I found following code to send email from Excel using a specific account. But the thing is I am using two different accounts in Outlook and want to send some emails using the account that I specify in a cell in the excel sheet. Can anyone please can make this 1 in Set .SendUsingAccount = OutApp.Session.Accounts.Item(1) brackets a variable linked to excel sheet instead of a constant so I can use it? I am using Excel 2016.

Code:
[COLOR=#3366CC]Sub Mail_small_Text_Change_Account()[/COLOR][COLOR=black]'Only working in Office 2007-2016
'Don't forget to set a reference to Outlook in the VBA editor[/COLOR]
    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)

    strbody = "Hi there" & vbNewLine & vbNewLine & _
              "This is line 1" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = strbody

        [COLOR=black]'SendUsingAccount is new in Office 2007
        'Change Item(1)to the account number that you want to use[/COLOR]
        Set .SendUsingAccount = OutApp.Session.Accounts.Item(1)

        .Send   [COLOR=black]'or use .Display[/COLOR]
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing [COLOR=#3366CC]End Sub[/COLOR]
 
Last edited:

Some videos you may like

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

fiberboysa

Board Regular
Joined
Apr 25, 2012
Messages
89
Office Version
2019
Platform
Windows
Please help so that i can pick that (1) in Set .SendUsingAccount = OutApp.Session.Accounts.Item(1) from a cell in a row. I have tried the following code but its not working giving me Run-tim error '5' Invalid procedure call or argument error...

Code:
Sub MailToDestination()    Dim SendTo As String
    Dim ToMSg As String
    Dim ToSubject As String
    Dim CC As String
    Dim AID As Integer
    For Each c In Range(Range("B2"), Range("B" & Cells.Rows.Count).End(xlUp))
        SendTo = c
        If Not (IsError(c.Offset(0, 1))) Then
            If c.Offset(0, 0) <> "" Then SendTo = c.Offset(0, 0)
        End If
        If SendTo <> “” Then
            ToSubject = c.Offset(0, 2)
            ToMSg = c.Offset(0, 3)
            CC = c.Offset(0, 1)
            AID = c.Offset(0, 6)
            Send_Mail SendTo, ToSubject, ToMSg, CC
        End If
    Next
End Sub
Sub Send_Mail(SendTo As String, ToSubject, ToMSg As String, CC As String)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrSignature As String
    Dim sPath As String
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    With OutMail
        .To = SendTo
        .CC = CC
        .BCC = ""
        .Subject = ToSubject
        .Body = ToMSg & vbCrLf & vbCrLf & "Best Regards,"
        Set .SendUsingAccount = OutApp.Session.Accounts.Item(AID)
        .Display  ' or just put .Send to directly send the mail instead of display
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,677
Hi,
Try this code:
Rich (BB code):
Sub MailToDestination()
  Dim SendTo As String
  Dim c As Range
  With CreateObject("Outlook.Application")
    For Each c In Range("B2", Range("B" & Cells.Rows.Count).End(xlUp))
      SendTo = Trim(c.Value)
      If SendTo <> "" Then
        .To = SendTo
        .CC = c.Offset(0, 1).Value
        .Subject = c.Offset(0, 2).ValueV
        .Body = c.Offset(0, 3).Value
        Set .SendUsingAccount = .Session.Accounts.Item(c.Offset(0, 6).Value)
        .Send ' or use .Display
      End If
    Next
  End With
End Sub
 
Last edited:

fiberboysa

Board Regular
Joined
Apr 25, 2012
Messages
89
Office Version
2019
Platform
Windows
Nope It did not worked. It game me error "Run-time error 424. Object Required"
I tried the following code...

Code:
Sub MailToDestination()    Dim SendTo As String
    Dim ToMSg As String
    Dim ToSubject As String
    Dim CC As String
    Dim AID As Integer
    For Each c In Range(Range("B2"), Range("B" & Cells.Rows.Count).End(xlUp))
        SendTo = c
        If Not (IsError(c.Offset(0, 1))) Then
            If c.Offset(0, 0) <> "" Then SendTo = c.Offset(0, 0)
        End If
        If SendTo <> “” Then
            ToSubject = c.Offset(0, 2)
            ToMSg = c.Offset(0, 3)
            CC = c.Offset(0, 1)
            AID = c.Offset(0, 6)
            Send_Mail SendTo, ToSubject, ToMSg, CC
        End If
    Next
End Sub
Sub Send_Mail(SendTo As String, ToSubject, ToMSg As String, CC As String)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrSignature As String
    Dim sPath As String
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    With OutMail
        .To = SendTo
        .CC = CC
        .BCC = ""
        .Subject = ToSubject
        .Body = ToMSg & vbCrLf & vbCrLf & "Best Regards,"
        Set .SendUsingAccount = OutApp.Session.Accounts.Item(c.Offset(0, 6).Value)
        .Display  ' or just put .Send to directly send the mail instead of display
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,677
I see now - there is my typo in this line .Subject = c.Offset(0, 2).ValueV
Should be
.Subject = c.Offset(0, 2).Value
 

fiberboysa

Board Regular
Joined
Apr 25, 2012
Messages
89
Office Version
2019
Platform
Windows
What code line has been yellowed by a debugger?
Same line which I need to be fixed :) i.e.
Code:
Set .SendUsingAccount = OutApp.Session.Accounts.Item(c.Offset(0, 6).Value)
 

fiberboysa

Board Regular
Joined
Apr 25, 2012
Messages
89
Office Version
2019
Platform
Windows
I see now - there is my typo in this line .Subject = c.Offset(0, 2).ValueV
Should be
.Subject = c.Offset(0, 2).Value
Above line is OK because I Just changed the line Set .SendUsingAccount = OutApp.Session.Accounts.Item(AID) to Set .SendUsingAccount = OutApp.Session.Accounts.Item(c.Offset(0, 6).Value)
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,677
Above line is OK because I Just changed the line Set .SendUsingAccount = OutApp.Session.Accounts.Item(AID) to Set .SendUsingAccount = OutApp.Session.Accounts.Item(c.Offset(0, 6).Value)
There is no such a line in my code, variable OutApp is not used in it.
Please copy/paste all the suggested code to a new VBA module and run it.
 
Last edited:

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,677
My bad, should be With CreateObject("Outlook.Application").CreateItem(0)
Rich (BB code):
Sub MailToDestination()
  Dim SendTo As String
  Dim c As Range
  With CreateObject("Outlook.Application").CreateItem(0)
    For Each c In Range("B2", Range("B" & Cells.Rows.Count).End(xlUp))
      SendTo = Trim(c.Value)
      If SendTo <> "" Then
        .To = SendTo
        .CC = c.Offset(0, 1).Value
        .Subject = c.Offset(0, 2).Value
        .Body = c.Offset(0, 3).Value
        Set .SendUsingAccount = .Session.Accounts.Item(c.Offset(0, 6).Value)
        .Send ' or use .Display
      End If
    Next
  End With
End Sub
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,102,478
Messages
5,487,115
Members
407,579
Latest member
chhantelravi

This Week's Hot Topics

Top