Using different e-mail account to send mail - excel

Question

I want to use a Excel macro to send a mail to a company. This mail should consist of a piece of text, a table and then the rest of the text.
In the function below I've compiled some code that works the way I want, but I would like to send the e-mail not from my personal account but from a corporate business account (in the code I refer to the latter as myemailadres#outlook.com). I think I have to use the .SendUsingAccount function, but if I implement it like shown below, the e-mail is send using my personal email account and not the one I specify. Can somebody help?
Sub Test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim TargetSheet As String
Dim i As Long
Dim StrBodybegin As String
Dim StrBodyend As String
Dim Startcell
Dim TargetRow As Integer
TargetSheet = Range("L24").value 'L24 refers to a name of a company, there is also a sheet in the workbook with the exact same name.
With Application.WorksheetFunction 'this I copied from the code from Ron de Bruijn
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
TargetRow = .Match("TOTAAL", ThisWorkbook.Worksheets(TargetSheet).Range("W1:W60"), 0) 'setting range of table I want to copy
Set Startcell = ThisWorkbook.Worksheets(TargetSheet).Range("W15")
Set rng = ThisWorkbook.Worksheets(TargetSheet).Range(Startcell, ThisWorkbook.Worksheets(TargetSheet).Cells(TargetRow + 1, 38))
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
StrBodybegin = "Text 1"
StrBodyend = "Text 2"
On Error Resume Next
With OutMail
.To = ThisWorkbook.Worksheets("Voorblad").Range("L23").value 'L23 refers to email adress
.CC = ""
.BCC = ""
.Subject = "Subject"
.HTMLBody = StrBodybegin & RangetoHTML(rng) & StrBodyend 'using the Ron de Bruin function RangetoHTML to copy in the table defined by the rng
.SendUsingAccount = OutApp.Session.Accounts("myemailadres#outlook.com") 'the line that does not work :(
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End With
End Sub

Answer 1

You can use the property .SentOnBehalfOfName = "user#domain" if you have access to that mailbox or user or whatever. Even if it's not added to your outlook, like this:
Option Explicit
Sub Test()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim TargetSheet As String
Dim i As Long
Dim StrBodybegin As String
Dim StrBodyend As String
Dim Startcell
Dim TargetRow As Integer
TargetSheet = Range("L24").Value 'L24 refers to a name of a company, there is also a sheet in the workbook with the exact same name.
With Application.WorksheetFunction 'this I copied from the code from Ron de Bruijn
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
TargetRow = .Match("TOTAAL", ThisWorkbook.Worksheets(TargetSheet).Range("W1:W60"), 0) 'setting range of table I want to copy
Set Startcell = ThisWorkbook.Worksheets(TargetSheet).Range("W15")
Set rng = ThisWorkbook.Worksheets(TargetSheet).Range(Startcell, ThisWorkbook.Worksheets(TargetSheet).Cells(TargetRow + 1, 38))
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
StrBodybegin = "Text 1"
StrBodyend = "Text 2"
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "user#domain"
.To = ThisWorkbook.Worksheets("Voorblad").Range("L23").Value 'L23 refers to email adress
.CC = ""
.BCC = ""
.Subject = "Subject"
.HTMLBody = StrBodybegin & RangetoHTML(rng) & StrBodyend 'using the Ron de Bruin function RangetoHTML to copy in the table defined by the rng
.SendUsingAccount = OutApp.Session.Accounts("myemailadres#outlook.com") 'the line that does not work :(
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End With
End Sub

Answer 2

Try, please:
.SendUsingAccount = outApp.GetNamespace("MAPI").accounts.Item("myemailadres#outlook.com")
And, when you try debugging, it is recommended to comment the line On Error Resume Next. You can not see where and what error appears. In fact, it should not exist at all, if everything is correct..

Answer 3

Find your account loop through accounts.
Dim outApp As object, outNS as object
Dim accounts As object, account As object, myAccount As object
set outApp =createobject("outlook.application")
set outNS = outApp.GetNamespace("MAPI")
Set accounts = outNS.Accounts
For Each account in accounts
if account.SmtpAddress = "myemailadrs#outlook.com" then
set myAccount = account
Exit For
end if
Next account
With outApp.CreateItem(0)
.to = "someone#abc.com"
'...
Set .SendUsingAccount = myAccount
'....
End With