Sending Emails with Attachments VBA - 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

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

Switching the FROM Inbox

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

How to attach created .pdf to email body with VBA

I have a converted document from .docx into .pdf saved to the desktop. The last task is to attach this .pdf to the body of an e-mail; the HTML signature should remain unchanged.
I think the problem is this line of code and I don't know how to correct it:
.Attachments.Add PdfFile.FullName
The complete code:
Public Sub Mail()
Dim LastAuthor As String
LastAuthor = ActiveDocument.BuiltInDocumentProperties("last Author")
Dim Email As String
Email = Replace(LastAuthor, " ", ".") & "#xyz.ro"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
.Signature = "HTMLbody"
.To = Email
.CC = ""
.BCC = ""
.Subject = ActiveDocument.Name
'.Body = "AVIZAT. Multumesc mult"
'.Attachments.Add ActiveDocument.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.HTMLbody = "AVIZAT, esantionul este in ordine. Multumesc" & "<br>" & .HTMLbody
Dim objDoc As Document
Set objDoc = ActiveDocument
objDoc.ExportAsFixedFormat _
OutputFileName:=Replace(objDoc.FullName, ".docx", ".pdf"), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile.FullName
'.Preview 'Preview the email must disable .send & MsgBox (or use .Send to send it)
.send
MsgBox "E-mail trimis cu succes"
Set OutMail = Nothing
Set OutApp = Nothing
End With
End Sub
This will do:
Public Sub Mail()
Dim LastAuthor As String
Dim Email As String
Dim MyPdfName As String
Dim objDoc As Document
LastAuthor = ActiveDocument.BuiltinDocumentProperties("last Author")
Email = Replace(LastAuthor, " ", ".") & "#xyz.ro"
Set objDoc = ActiveDocument
MyPdfName = Replace(objDoc.FullName, ".docx", ".pdf")
objDoc.ExportAsFixedFormat _
OutputFileName:=MyPdfName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = Email
.CC = ""
.BCC = ""
.Subject = objDoc.Name
.HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri>Servus<br>Esantionul este in ordine.<br><br>Multumesc,<br>" & .HTMLBody
.Attachments.Add MyPdfName
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "E-mail trimis cu succes"
End Sub
It's far from perfect but is a lot clearer now and most importantly, works.

How do I insert a linebreak when sending an email using VBA Access

Using the object "Outlook.Application", I send an e-mail using VBA Access. In the body, I put a string like this:
Email = "Random things" & Chr(13) _
& "More random things" & Chr(13) _
If I show the string Email in a MsgBox it is displayed correctly, but when I send it, the linebreaks are deleted.
I've tried with:
Chr(13)
vbCrLf
vbCr
But all three have the same result:
Try This:
Sub OutlookEmail()
Dim AppOutlook As Outlook.Application
Set AppOutlook = CreateObject("Outlook.application")
Dim Mail As MailItem
Set Mail = AppOutlook.CreateItem(olMailItem)
Dim Email As String
Email = "Random things" & vbNewLine _
& "More random things" & vbNewLine
'Generate Email
Mail.Subject = "Test Subject"
Mail.To = "Test#test.com"
Mail.Body = Email
Mail.Display
Set Mail = Nothing
Set AppOutlook = Nothing
End Sub
Tested it my self appears to work correctly on my PC.
The code below display the email in Outlook. To send, change .Display to .Send
Sub SendDisplayEmail(strEmailFrom As String, strEmailTo As String, strEmailCC As String, strEmailBCC As String, strSubject As String)
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0) ' olMailItem
Debug.Print ("From: " & strEmailFrom & ", To: " & strEmailTo & ", cc: " & strEmailCC & ", bcc: " & strEmailBCC & ", file: " & xFile)
On Error Resume Next
OutMail
With OutMail
.to = strEmailTo
.CC = strEmailCC
.BCC = strEmailBCC
.Subject = strSubject
'.Body = "Random things" _
' & vbCrLf & vbCrLf & "More random things." _
.BodyFormat = 2 ' olFormatHTML
.HTMLBody = "<html>Random things<br>More random things.</html>"
'.Body = strBody
'.Save
.Display
'.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
You can use the HTMLBody (with .BodyFormat = 2) for a nice formated e-mail or .Body for the plain text e-mail. Note that %0D%0A and dont work in HTMLBody because Outlook parse it.