VBA - Send An Email Using Account That I Want

fiberboysa

Board Regular
Joined
Apr 25, 2012
Messages
106
Office Version
  1. 365
Platform
  1. 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:

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
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
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
I see now - there is my typo in this line .Subject = c.Offset(0, 2).ValueV
Should be
.Subject = c.Offset(0, 2).Value
 
Upvote 0
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)
 
Upvote 0
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:
Upvote 0
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:
Upvote 0

Forum statistics

Threads
1,213,521
Messages
6,114,104
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top