Switching the FROM Inbox - vba
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
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
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...
You can use the .SendUsingAccount property
https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.sendusingaccount
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
Related
Sending letter from a specific mailbox [duplicate]
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
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
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...
You can use the .SendUsingAccount property https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.sendusingaccount
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
vba outlook adding newline between content and signature
Hi trying to add a newline between my body content after paste a table and signature,codes are below: dim FileName As String Dim filepath As String Dim rng As Range Dim OutlookApp As Object Dim Outlookmail As Object Dim lastrowo As Integer Application.ScreenUpdating = False Set OutlookApp = CreateObject("Outlook.Application") Set Outlookmail = OutlookApp.CreateItem(0) lastrowo = Worksheets("Price And Accrued Info").Range("K550").End(xlUp).row Set rng = Worksheets("Price And Accrued Info").Range("K2:y" & lastrowo) rng.Copy Dim vInspector As Object Set vInspector = Outlookmail.GetInspector Dim wEditor As Object Set wEditor = vInspector.WordEditor With Outlookmail .To = "" .cc="" .Subject = "UNCONFIRMED TRADES AS OF " & Format$(Date, "YYYY.MM.DD") wEditor.Paragraphs(1).Range.Text = "Hi The following trades are unconfirmed trades." wEditor.Paragraphs(2).Range.Paste wEditor.Paragraphs(4).Range.Text = vbNewLine & "<br>" .display ' .attachments.Add drWorkbook.FullName ' .attachments.Add crWorkbook.FullName ' End With Set Outlookmail = Nothing Set OutlookApp = Nothing Application.ScreenUpdating = True
Try this: With Outlookmail .To = "" .cc = "" .Subject = "UNCONFIRMED TRADES AS OF " & Format$(Date, "YYYY.MM.DD") wEditor.Paragraphs(1).Range.Text = "Hi The following trades are unconfirmed trades." _ & String(5, vbNewLine) wEditor.Paragraphs(5).Range.Text = "This is is the last line." _ & vbNewLine & vbNewLine wEditor.Paragraphs(3).Range.Paste .display End With
Sending Emails with Attachments VBA
I am trying to add an attachment functionality to my emails. My email code is working however the attachments are being sent as ATT00001.bin files. The variable Forms![frmMain]!TabCtl54.Pages("page56").Controls("subtblcontent").Form![attachmentlnk] is a textbox on a form which is where I would put my file name. attachmentlnkvar = "file:///C:/Users/desktopname/Desktop/" & Forms![frmMain]!TabCtl54.Pages("page56").Controls("subtblcontent").Form![attachmentlnk] & ".pdf" With cdomsg .To = emailstr .FROM = fromemailstr .subject = Forms!frmMain.txtSubject .Attachments.Add attachmentlnkvar .HTMLBody = strHTML .Send End With Set cdomsg = Nothing Is there a way I can send my files as pdfs?
I am happy to share with you the function which I use to sent all my emails: Public Sub SendMessage(Optional SubjectText = "", Optional BodyText = "", Optional AttachmentPath = "", Optional sendTo = "", Optional sendCC = "", Optional DeliveryConfirmation = True, Optional DisplayDoNotAutoSend = True, Optional SendHighPriority = True, Optional UseHTML = True) Dim objOutlook As Outlook.Application Dim objOutlookMsg As Outlook.MailItem Dim objOutlookRecip As Outlook.Recipient Dim objOutlookAttach As Outlook.Attachment Dim MultipleAttachmentPath As String Dim CurrentAttachment As Variant Dim aAtachments() As String On Error GoTo ErrorMsgs DoCmd.Hourglass True ' Create the Outlook session. Set objOutlook = New Outlook.Application ' Create the message. Set objOutlookMsg = objOutlook.CreateItem(olMailItem) With objOutlookMsg If UseHTML Then .BodyFormat = olFormatHTML End If If Not isnull(sendTo) And InStr(sendTo, "#") > 0 Then .To = sendTo End If If Not isnull(sendCC) And InStr(sendCC, "#") > 0 Then .CC = sendCC End If .Subject = SubjectText If UseHTML Then .HTMLBody = "<div style='font-family:Calibri,sans-serif'>" & BodyText & GetThankYouSignature & "</div>" Else .Body = BodyText & vbCrLf & GetUserFullNameInASCIIText & vbCrLf & vbCrLf End If If SendHighPriority Then .Importance = olImportanceHigh 'High importance End If If DeliveryConfirmation Then .OriginatorDeliveryReportRequested = True .ReadReceiptRequested = True End If On Error Resume Next If AttachmentPath <> "" Then ' Add attachments to the message. If Not IsMissing(AttachmentPath) And InStr(AttachmentPath, ";") = 0 Then Set objOutlookAttach = .Attachments.add(AttachmentPath) ElseIf Not IsMissing(AttachmentPath) And InStr(AttachmentPath, ";") > 0 Then aAtachments = Split(AttachmentPath, ";") For Each CurrentAttachment In aAtachments .Attachments.add (CurrentAttachment) Next End If End If On Error GoTo ErrorMsgs End With If DisplayDoNotAutoSend Or isnull(sendTo) Then objOutlookMsg.Display Else objOutlookMsg.Send End If Set objOutlookMsg = Nothing Set objOutlook = Nothing Set objOutlookRecip = Nothing Set objOutlookAttach = Nothing DoCmd.Hourglass False Exit Sub ErrorMsgs: DoCmd.Hourglass False If Err.Number = "287" Then MsgBox "You clicked No to the Outlook security warning. " & _ "Rerun the procedure and click Yes to access e-mail" & _ "addresses to send your message. For more information," & _ "see the document at http://www.microsoft.com/office" & _ "/previous/outlook/downloads/security.asp. " Else Call LogError(Err.Number, Err.Description, "SystemUtilities", "SendMessage") Resume Next Resume End If End Sub The variable AttachmentPath can contain multiple paths to attachments delimited by ";"
Don't use file:// etc., just the path. And backslashes. attachmentlnkvar = "C:\Users\desktopname\Desktop\" & Forms![frmMain]!TabCtl54.Pages("page56").Controls("subtblcontent").Form![attachmentlnk] & ".pdf"
Instead of .Attachments.Add attachmentlnkvar have you tried .AddAttachment attachmentlnkvar? That's what I use to send PDF reports via an SMTP server instead of Outlook.
The problem is with your SMTP server. Try putting the attachment after the body to avoid this problem. If that doesn't work, try sending the message as plain text instead of HTML using: .TextBody = bodyText EXAMPLE: attachmentlnkvar = "C:/Users/desktopname/Desktop/" & Forms![frmMain]!TabCtl54.Pages("page56").Controls("subtblcontent").Form![attachmentlnk] & ".pdf" With cdomsg .To = emailstr .FROM = fromemailstr .Subject = Forms!frmMain.txtSubject .HTMLBody = strHTML .AddAttachment attachmentlnkvar .Send End With Set cdomsg = Nothing EXPLANATION: https://kb.mit.edu/confluence/pages/viewpage.action?pageId=4981187
Extract the values in a drop-down field
I would like to extract the values in a drop-down field with the title "email address". I would like the name selected to appear in the email "To" line. I'm adding the ActiveDocument details to the subject line but would like to remove the .docx portion of the subject line. Do I need separate Outlook code? Sub RunAll() Call Save Call sendeMail End Sub Sub Save() Dim strPath As String Dim strPlate As String Dim strName As String Dim strFilename As String Dim oCC As ContentControl strPath = "C:\Users\******x\Desktop\Test 4" CreateFolders strPath On Error GoTo err_Handler Set oCC = ActiveDocument.SelectContentControlsByTitle("License Plate Number").Item(1) If oCC.ShowingPlaceholderText Then MsgBox "Complete the License plate number!" oCC.Range.Select GoTo lbl_Exit Else strPlate = oCC.Range.Text End If Set oCC = ActiveDocument.SelectContentControlsByTitle("Customer Name").Item(1) If oCC.ShowingPlaceholderText Then MsgBox "Complete the Customer Name!" oCC.Range.Select GoTo lbl_Exit Else strName = oCC.Range.Text End If strFilename = strPlate & "__" & strName & ".docx" ActiveDocument.SaveAs2 FileName:=strPath & strFilename, FileFormat:=12 lbl_Exit: Set oCC = Nothing Exit Sub err_Handler: MsgBox Err.Number & vbCr & Err.Description Err.Clear GoTo lbl_Exit End Sub Private Sub CreateFolders(strPath As String) Dim oFSO As Object Dim lngPathSep As Long Dim lngPS As Long If Right(strPath, 1) <> "\" Then strPath = strPath & "\" lngPathSep = InStr(3, strPath, "\") If lngPathSep = 0 Then GoTo lbl_Exit Set oFSO = CreateObject("Scripting.FileSystemObject") Do lngPS = lngPathSep lngPathSep = InStr(lngPS + 1, strPath, "\") If lngPathSep = 0 Then Exit Do If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do Loop Do Until lngPathSep = 0 If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then oFSO.CreateFolder Left(strPath, lngPathSep) End If lngPS = lngPathSep lngPathSep = InStr(lngPS + 1, strPath, "\") Loop lbl_Exit: Set oFSO = Nothing Exit Sub End Sub Private Sub sendeMail() Dim olkApp As Object Dim strSubject As String Dim strTo As String Dim strBody As String Dim strAtt As String strSubject = "VR*** Request: " + ActiveDocument + " CUSTOMER IS xx xx xx" strBody = "" strTo = "" If ActiveDocument.FullName = "" Then MsgBox "activedocument not saved, exiting" Exit Sub Else If ActiveDocument.Saved = False Then If MsgBox("Activedocument NOT saved, Proceed?", vbYesNo, "Error") <> vbYes Then Exit Sub End If End If strAtt = ActiveDocument.FullName Set olkApp = CreateObject("outlook.application") With olkApp.createitem(0) .To = strTo .Subject = strSubject .body = strBody .attachments.Add strAtt '.send .Display End With Set olkApp = Nothing End Sub
To get the doc's name without the extension, you can use this: Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) InStrRev finds the last "dot" . Left truncates the name until that position -1 applied to the found position is to also remove the . itself For example, strSubject = "VR*** Request: " & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & " CUSTOMER IS xx xx xx" Addendum To get the email address from a content-control titled "email address", you can use this function: Function getEmailAddress() Dim sh As ContentControl For Each sh In ThisDocument.Range.ContentControls If sh.Title = "email address" Then getEmailAddress = sh.Range.Text Exit Function End If Next End Function i.e. With olkApp.createitem(0) .To = getEmailAddress ' etc...
Outlook reply macro not displaying images
I have a macro that will open a reply to a selected email with a template. However, the rest of the images in the email machine now just showe a red cross. Can anyone see why this might be happening? Sub TacReply() Dim origEmail As MailItem Dim replyEmail As MailItem Set origEmail = Application.ActiveExplorer.Selection(1) Set replyEmail = Application.CreateItemFromTemplate("S:\Share\TWGeneral.oft") replyEmail.To = origEmail.SenderEmailAddress replyEmail.Subject = origEmail.Subject replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody replyEmail.SentOnBehalfOfName = "email#address.com" replyEmail.Display End Sub Thanks :)
Just in case anyone has the same problem, here was the solution I used: Sub Forward_Mail_Outlook_With_Signature_Html_2() Dim MyItem As Object Dim MyFwdItem As MailItem Dim SigString As String Dim Signature As String Set MyItem = ActiveExplorer.Selection(1).reply If MyItem.Class = olMail Then Set MyFwdItem = MyItem.Forward 'Change only Mysig.htm to the name of the signature SigString = Environ("appdata") & _ "\Microsoft\Signatures\Your Signature.htm" If Dir(SigString) <> "" Then Signature = GetBoiler(SigString) Else Signature = "" End If With MyFwdItem .To = MyFwdItem.SenderEmailAddress .subject = MyFwdItem.subject .HTMLBody = "<br>" & Signature & .HTMLBody .SentOnBehalfOfName = "youremail#address.com" .Display End With Else MsgBox "Select a mailitem." End If ExitRoutine: Set MyItem = Nothing Set MyFwdItem = Nothing End Sub Private Function GetBoiler(ByVal sFile As String) As String Dim fso As Object Dim ts As Object Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) GetBoiler = ts.readall ts.Close End Function