Sending letter from a specific mailbox [duplicate] - vba

Question

I currently use a code that generates an email fine with certain fields like To, CC, BCC, but I am not sure how to switch the "FROM" part of the email automatically.
Ie my email is here, but I want to automatically switch to another inbox,
I can do it manually when the email is generated via the drop down, but I am wondering if there are ways to do this automatically. I Tried adding .From to this existing code but does not work.
Here are the relevant snippets of code:
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)
With Mitem
'send to:
.To = send_list
'send from:
'.From = from_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
.From = from_list is not a supported property.
Does anyone know how to alter this code to add the "From" parameter correctly?
FULL CODE
Sub Create_Email()
' Creates e-mail to send
Application.ScreenUpdating = False
Sheets("Emails Management").Select
ActiveSheet.Calculate
top_line_emails = 2 'hardcoded to row 2
max_row_emails = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1 'last row
ref_title_line = Application.WorksheetFunction.Match("Email Name", Columns(1), False) 'gets title row
indexActive = Application.WorksheetFunction.Match("Active", Rows(ref_title_line), False)
indexType = Application.WorksheetFunction.Match("Type", Rows(ref_title_line), False)
indexEmailName = Application.WorksheetFunction.Match("Email Name", Rows(ref_title_line), False)
indexsubject = Application.WorksheetFunction.Match("Subject", Rows(ref_title_line), False)
indexfiles = Application.WorksheetFunction.Match("Attachments", Rows(ref_title_line), False)
indexSendTo = Application.WorksheetFunction.Match("Send To", Rows(ref_title_line), False)
indexSendFrom = Application.WorksheetFunction.Match("Send From", Rows(ref_title_line), False)
indexCC = Application.WorksheetFunction.Match("CCed", Rows(ref_title_line), False)
indexBCC = Application.WorksheetFunction.Match("BCCed", Rows(ref_title_line), False)
indexGreetings = Application.WorksheetFunction.Match("Greetings", Rows(ref_title_line), False)
indexBody = Application.WorksheetFunction.Match("Body Text", Rows(ref_title_line), False)
indexSignature = Application.WorksheetFunction.Match("Signature", Rows(ref_title_line), False)
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Dim oMail As Object
Set fso = CreateObject("Scripting.FileSystemObject")
user_name = Environ("Username")
ref_row = top_line_emails 'hardcoded for row 2
'finds the reports that were generated
Do While ref_row <= max_row_emails
Set OLook = CreateObject("Outlook.Application")
Set Mitem = OLook.CreateItem(0)
Set OlAttachment = Mitem.attachments
send_list = ""
from_list = ""
cc_list = ""
bcc_list = ""
attach_name = ""
whole_text = ""
Body_text = ""
If Range(ColumnNumberToLetter(indexEmailName) & ref_row).Value = "" Then 'looping down the rows, if it is blank stop generating emails.
Exit Do
End If
go_for_it = True
If go_for_it = True Then
file_name = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
send_list = Range(ColumnNumberToLetter(indexSendTo) & ref_row)
from_list = Range(ColumnNumberToLetter(indexSendFrom) & ref_row)
cc_list = Range(ColumnNumberToLetter(indexCC) & ref_row)
bcc_list = Range(ColumnNumberToLetter(indexBCC) & ref_row)
Signature = Range(ColumnNumberToLetter(indexSignature) & ref_row).Value
attachment = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value 'not attaching
'On Error GoTo no_email, Gets the text of the Email
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexGreetings) & ref_row)
'This section gets the text part of the email.
If remail = "" Then
greetings_text = ""
Else
greetings_text = RangetoHTML2(remail)
greetings_text = get_date_cnv(greetings_text, ref_date_email)
End If
'Body text , Meant for charts
If Range(ColumnNumberToLetter(indexBody) & ref_row).Value <> "" Then
body_full_text = Range(ColumnNumberToLetter(indexBody) & ref_row).Value
'count the number of < in the body text
graphic_count = Len(body_full_text) - Len(Replace(body_full_text, "<", ""))
For Count = 1 To graphic_count
'search the start and end of the graphic range
body_start_search = InStr(1, body_full_text, "<")
body_end_search = InStr(1, body_full_text, ">")
'if there are <> then go for it
If body_start_search <> 0 And body_end_search <> 0 Then
'isolate the text in the <>
graphic_area = RTrim(LTrim(Mid(Left(body_full_text, body_end_search), body_start_search)))
'make sure the <> is not a <br> (line break)
If graphic_area <> "" And graphic_area <> "<br>" Then
'body_text = body_text & Left(body_full_text, body_start_search - 1)
graphic_area = Replace(Replace(graphic_area, "<", ""), ">", "")
'pull out the graphic type
graphic_type_search = InStr(1, graphic_area, ",")
graphic_type = Left(graphic_area, graphic_type_search - 1)
graphic_area = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_type_search)))
'pull out the tab name
graphic_tab_search = InStr(1, graphic_area, ",")
graphic_tab = Left(graphic_area, graphic_tab_search - 1)
'pull out the graphic area
graphic_rng = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_tab_search)))
Select Case LCase(graphic_type)
Case "chart"
Body_text = Body_text & "<br>" & RangetoHTML(Sheets(graphic_tab).Range(graphic_rng))
Case "text"
Body_text = Body_text & "<br>" & RangetoHTML2(Sheets(graphic_tab).Range(graphic_rng))
'Need to put graph part here
End Select
If Len(body_full_text) = body_end_search Then
Exit For
End If
body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
Else
If IsEmpty(Body_text) Then
Body_text = Left(body_full_text, body_start_search - 1)
Else
If Len(body_full_text) = body_end_search Then
Exit For
End If
Body_text = Body_text & "<br>" & Left(body_full_text, body_start_search - 1)
End If
If Len(body_full_text) = body_end_search Then
Exit For
End If
body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
End If
Else
Body_text = Body_text & body_full_text & "<br>"
End If
Next Count
Body_text = Body_text & "<br>" & body_full_text
End If
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexBody) & ref_row)
'signature
Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexSignature) & ref_row)
end_text = RangetoHTML2(remail)
'creates the whole text in email
whole_text = greetings_text & "<br>" & Body_text & "<br>" & "<br>" & end_text
'create email, but does not send
Set Mitem = OLook.CreateItem(0)
With Mitem
.SendUsingAccount = GetAccountOf("email#blah.com", OLook)
.Display
'send to:
.To = send_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list
'attaching files
On Error GoTo resume_here
If Range(ColumnNumberToLetter(indexfiles) & ref_row).Value <> "" Then
file_name = Sheets("Emails Management").Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
file_count = Len(file_name) - Len(Replace(file_name, ";", "")) + 1
For Count = 1 To file_count
file_search = InStr(1, file_name, ";")
If file_search = 0 Then
attach_name = RTrim(LTrim(file_name))
Else
attach_name = RTrim(LTrim(Left(file_name, file_search - 1)))
End If
ref_date = Sheets("Start").Range("D2").Value
attach_name = get_date_cnv(attach_name, ref_date)
file_name = Right(file_name, Len(file_name) - file_search)
file_name = get_date_cnv(file_name, ref_date_email)
.attachments.Add attach_name
Next Count
End If
resume_here:
'email subject
.Subject = get_date_cnv(Range(ColumnNumberToLetter(indexsubject) & ref_row).Value, ref_date_email)
'email body
.HTMLBody = whole_text
'.HTMLBody = graphic_desc
'check names in outlook
.Recipients.ResolveAll
'display email
'.Display
'save as draft
.Save
'.Send
Application.ScreenUpdating = True
Application.ScreenUpdating = False
End With
DoEvents
End If
ref_row = ref_row + 1
Loop
Set fso = Nothing
Set OLook = Nothing
Set Mitem = Nothing
Set OlAttachment = Nothing
Exit Sub
no_email:
MsgBox ("Error creating emails: " & Err.Description)
Set fso = Nothing
Set OLook = Nothing
Set Mitem = Nothing
Set OlAttachment = Nothing
Exit Sub
End Sub

Answer 1

Try this function
Function GetAccountOf(sEmailAddress As String, ByRef OLook As Object) As Object
Dim oAccount As Object
Set GetAccountOf = Nothing
For Each oAccount In OLook.Session.Accounts
If oAccount = sEmailAddress Then
Set GetAccountOf = oAccount
Exit Function
End If
Next oAccount
End Function
You can then replace the .From line with:
.SendUsingAccount = GetAccountOf("emailaddress#somewhere.com", OLook)
Edit: Follow-up to comments below:
If the above doesn't work then I suspect there's something with your outlook that is causing this. You need to think of ways/questions to help determine the problem, such as
Is the account you want to use completely set-up within outlook?
When you send email manually from this account does outlook ask you for password?
Try also to think of test code you can use to narrow down the possibilities that may be the cause of the problem. for example try to run these subroutines and see if the first code actually lists your desired account. Does the second code result in the account being Nothing? If so, perhaps an option is to delete the account and add it again to outlook, which may help reset something that was causing the problem.
Sub ShowAllAccounts()
Dim OLook As Object
Dim oAccount As Object
Set OLook = CreateObject("Outlook.Application")
For Each oAccount In OLook.Session.Accounts
MsgBox oAccount.DisplayName
Next oAccount
End Sub
Sub DoesAccountExist()
Dim OLook As Object
Set OLook = CreateObject("Outlook.Application")
If GetAccountOf("emailaddress#somewhere.com", OLook) Is Nothing Then
MsgBox "Account doesn't exist"
End If
End Sub
Try to make up some other code similar to this and please get back if you are still stuck.
Edit 2:
You need to make sure you set the SendUsingAccount property before you .Display your email: Outlook if funny like that :)
Try this:
Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)
With Mitem
.SendUsingAccount = GetAccountOf("emailaddress#somewhere.com", OLook)
.Display
'send to:
.To = send_list
'send from:
'.From = from_list
'cc to:
.CC = cc_list
'bcc to:
.BCC = bcc_list

Answer 2

Try the next approach, please:
Sub SendUsingDifferentAccount()
Dim OLook As New Outlook.Application
Dim acc As Outlook.account
Dim Mitem As Outlook.MailItem
Set Mitem = OLook.CreateItem(0)
For Each acc In OLook.Session.accounts
If acc.DisplayName = "testaccount#yourdomain.com" Then
With Mitem
.To = "..."
.cc = "..."
.BCC = "..."
Set .SendUsingAccount = acc
.send
End With
Exit For
End If
Next
End Sub
If needs a reference to 'Microsoft Outlook ... Object Library. Or declare all above object variables As Object`. But it is better to reference Outlook. You can benefit of the intellisense advantage...

Answer 3

You can use the .SendUsingAccount property
https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.sendusingaccount

Answer 4

I use the following approach to send mails from a specific Outlook account (IMAP, no Exchange Server). The code relies on an already opened outlook instance (but that can easily be changed)
Option Explicit
Public Enum oCreateMail
oSave = 1
oDisplay = 2
oSend = 4
End Enum
Public Sub RunSendMail()
Dim OutlookApp As Outlook.Application
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If OutlookApp Is Nothing Then
MsgBox "Please open Outlook first.", vbExclamation, "Open Outlook"
Exit Sub
End If
'load a template for your mail if necessary
Dim TemplateFile As String
TemplateFile = ThisWorkbook.Path & Application.PathSeparator & "template_message.msg"
'Name of Outlook account that should be used
Dim AccountName As String
AccountName = "account_1#acme.com"
Dim OutlookAccount As Outlook.Account
Set OutlookAccount = GetAccountByName(OutlookApp, AccountName)
If OutlookAccount Is Nothing Then
MsgBox "Outlook account '" & AccountName & "' was not found!", vbCritical, "Outlook Account"
Exit Sub
End If
'send a mail from a specific account
SendMail OutlookApp, OutlookAccount, "send_to#acme.com", oDisplay, "" 'use TemplateFile as template if you don't want to create the mail from scratch.
End Sub
Public Sub SendMail(ByVal OutlookApp As Outlook.Application, ByVal OutlookAccount As Outlook.Account, ByVal MailTo As String, Optional ByVal MailAction As oCreateMail = 2, Optional ByVal TemplateFile As String)
Dim NewMail As Outlook.MailItem
If TemplateFile <> vbNullString Then
Set NewMail = OutlookApp.CreateItemFromTemplate(TemplateFile)
Else
Set NewMail = OutlookApp.Createitem(0)
End If
With NewMail
.SendUsingAccount = OutlookAccount
'remove a automatically added signature if necessary
'RemoveAutoSignature NewMail
'new email from scratch
.HTMLBody = "test mail"
'alternatively replace something in the template:
'.HTMLBody = Replace$(.HTMLBody, "Placeholder", "Fill in TEXT")
.To = MailTo
Select Case MailAction
Case oDisplay
.Display
Case oSend
.Send
Case oSave
.Save
.Close olSave
End Select
End With
End Sub
Public Sub RemoveAutoSignature(ByRef Mail As Outlook.MailItem)
Dim oDocument As Word.Document
Set oDocument = Mail.GetInspector.WordEditor
Dim oBookmark As Word.Bookmark
Set oBookmark = oDocument.Bookmarks.Item("_MailAutoSig")
If Not oBookmark Is Nothing Then
oBookmark.Select
oDocument.Windows.Item(1).Selection.Delete
End If
End Sub
Public Function GetAccountByName(ByVal oApp As Outlook.Application, ByVal AccountName As String) As Outlook.Account
Dim oAccount As Outlook.Account
For Each oAccount In oApp.Session.Accounts
If oAccount.DisplayName = AccountName Then
Set GetAccountByName = oAccount
Exit For
End If
Next oAccount
End Function
The following can be used to list all available Outlook mail accounts:
Public Sub GetAllOutlookAccounts(ByVal oApp As Outlook.Application)
Dim oAccount As Outlook.Account
For Each oAccount In oApp.Session.Accounts
Debug.Print oAccount.DisplayName
Next oAccount
End Sub
Public Sub ListAllOutlookAccounts()
GetAllOutlookAccounts GetObject(, "Outlook.Application")
End Sub