VBA - Send An Email Using Account That I Want

[fiberboysa]

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.

[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]

 

[fiberboysa]

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...

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]

Hi,
Try this 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

 

[fiberboysa]

Nope It did not worked. It game me error "Run-time error 424. Object Required"
I tried the following 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]

Nope It did not worked. It game me error "Run-time error 424. Object Required"

What code line has been yellowed by a debugger?

 

[ZVI]

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]

What code line has been yellowed by a debugger?

Same line which I need to be fixed i.e.

Set .SendUsingAccount = OutApp.Session.Accounts.Item(c.Offset(0, 6).Value)

 

[fiberboysa]

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]

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.

 

[ZVI]

My bad, should be With CreateObject("Outlook.Application").CreateItem(0)

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