Send Email with Attachments located in same folder as the workbook - excel

I generate an Outlook HTML formatted email to send to the email address designated by cell.
I attach multiple files located in the same folder as the workbook with the FileDialog box.
I would like the initial folder that comes up to be the location of the current workbook.
Private Sub CommandButton1_Click()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C14").Value
.Subject = Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " Tile Estimate"
.HTMLBody = Range("B14").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the" & Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click()
End Sub

Update, here is what I ended up using
Sub Email_1()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.Filters.Clear
xFileDlg.Filters.Add "pdf files", "*.pdf"
xFileDlg.AllowMultiSelect = True
xFileDlg.InitialFileName = ThisWorkbook.Path
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C13").Value
.Subject = Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " Tile Estimate"
.HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Range("B13").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the " & Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub

Related

How can I send a mail with a condition?

I would like the message to be sent when there is a value in column H, for example "y" -> enter image description here
Sub sendCustEmails()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(oMailItem)
Dim strMailBody As String
intRow = 2
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
While (strISO <> "")
Set objEmail = objOutlook.CreateItem(oMailItem)
StrMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailBody = "<BODY style='font-size:11pt;font-family:Calibri(Body)'>" & ThisWorkbook.Sheets("Mail_Details").Range("B2").Text & "</BODY>"
strMailBody = Replace(strMailBody, Chr(10), "<br>")
strFolder = "C:\Users\CIOTTIC\OneDrive - IAEA\Desktop\AL TEST"
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
strSalutation = ThisWorkbook.Sheets("MS_Data").Range("C" & intRow).Text
strEmail = ThisWorkbook.Sheets("MS_Data").Range("D" & intRow).Text
strCC = ThisWorkbook.Sheets("MS_Data").Range("E" & intRow).Text
strFile = ThisWorkbook.Sheets("MS_Data").Range("F" & intRow).Text
strFile2 = ThisWorkbook.Sheets("MS_Data").Range("G" & intRow).Text
StrMailSubject = Replace(StrMailSubject, "<ISO>", strISO)
strMailBody = Replace(strMailBody, "<Salutation>", strSalutation)
With objEmail
.To = CStr(strEmail)
.CC = CStr(strCC)
.Subject = StrMailSubject
.BodyFormat = olFormatHTML
.Display
.Attachments.Add strFolder & "\" & strFile
.Attachments.Add strFolder & "\" & strFile2
.HTMLBody = strMailBody & .HTMLBody
.Send
End With
intRow = intRow + 1
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & intRow).Text
Wend
MsgBox "Done"
End Sub
Thank you very much!
How about :
Sub Test()
If Range("A1").Value <> "" Then
GoTo SendEmail
Else: Exit Sub
End If
Send Email:
'Enter the rest of your code here.
End Sub
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub sendCustEmails_WithCondition()
' Late binding
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Dim strISO As String
Dim strMailSubject As String
Dim longRow As Long
longRow = 2
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
Debug.Print "strISO: " & strISO
While (strISO <> "")
If ThisWorkbook.Sheets("MS_Data").Range("H" & longRow).Text = "Y" Then
'Typo - use Option Explicit
'Set objEmail = objOutlook.CreateItem(oMailItem)
' For early binding oMailItem should be olMailItem
' This is "accepted" in late binding without Option Explicit.
' Appears the variable "oMailItem" which is empty is treated as a zero.
Set objEmail = objOutlook.CreateItem(0)
'strMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailSubject = "Subject is <ISO>"
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
strMailSubject = Replace(strMailSubject, "<ISO>", strISO)
Debug.Print " strMailSubject: " & strMailSubject
With objEmail
.Subject = strMailSubject
.Display
End With
Else
' Not Y
Debug.Print " No mail."
End If
longRow = longRow + 1
strISO = ThisWorkbook.Sheets("MS_Data").Range("B" & longRow).Text
Debug.Print "strISO: " & strISO
Wend
MsgBox "Done"
End Sub

Outlook image error when pasting a range as a picture

I have this code that emails a range as a picture via outlook. The problem is that the recipients are getting the outlook error "The linked image cannot be displayed. The file may have been moved, renamed, or deleted. Verify that the link points to the correct file and location."
Anyone know how I can fix this?
Sub RectangleRoundedCorners1_Click()
ActiveSheet.Unprotect Password:="Mortgage1"
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = ActiveSheet.Range("C5:F17")
If xRg Is Nothing Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
ActiveSheet.Shapes("Rectangle: Rounded Corners 13").Visible = False
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<img src='cid:DashboardFile.jpg'>" _
'& "<br> "
StrBody = "<br />" & "<b><FONT SIZE = 5><font color=red>Rates are subject to change
without notice</b></FONT SIZE = 5></font color=red>"
With xOutMail
.Subject = "Bench Mark Rates" & " " & Date
.HTMLBody = xHTMLBody & StrBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = "mcerrato#hotmail.com
.cc = "mcerrato#loandepot.com"
.Display
End With
ActiveSheet.Shapes("Rectangle: Rounded Corners 13").Visible = True
ActiveSheet.Protect Password:="Mortgage1"
End Sub
Just try so switch this two lines
As is
.HTMLBody = xHTMLBody & StrBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
To be
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.HTMLBody = xHTMLBody & StrBody

Loop through all Outlook inboxes including shared inboxes error

I have code that will search through a user's Outlook and reply to an email depending on the Subject phrase you input in the worksheet cell. I did have it working a couple days ago, but now I can not seem to get it to work (was deleted). Once run, an error message will continuously display for code line "Set olitems = flrd.Items", saying "Object variable or With block variable not set". I think the problem is the End if but wherever I place it either the code does nothing or the same error displays.
The only other problem with the working code (when it worked) was that it populated more than once. I wish it to populate only one time.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
On Error Resume Next
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
End if
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
Set Fldr = StoreInbox
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub
Firstly, get rid of the On Error Resume Next line.
Secondly, Fldr variable is never set. Did you mean to use storeInbox variable instead?
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Dim allStores As Stores
Dim storeInbox As Folder
Dim j As Long
Set allStores = Session.Stores
For j = 1 To allStores.count
On Error Resume Next
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
On Error GoTo 0
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
"<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
"Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End if
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub

Hide screen updating when sending mail with Outlook

I have to send reports to over 400 email addresses (on column B). The filepaths for each report are on columns C, D and E.
With this post: How to add default signature in Outlook the signature is added when the .display method is used.
The signature I want to show is for user number 1. I've selected the corresponding signature as a default signature for new messages.
This signature contains a picture, but this doesn't seem to cause any problems.
I wouldn't want the macro to show the mail every time it sends the mail, because I want to avoid the constant blinking on the screen.
I tried to look for something like "hide" method from here but didn't find anything useful (.display would run in the background, and it would stay hidden from the user). Other idea was to add application.screenupdating = false and correspondingly true in the end, but this didn't have any impact.
How could I display the email in the background without showing it every time to the user?
Sub sendFiles_weeklyReports()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim EmailCell As Range
Dim FileCell As Range
Dim rng As Range
Dim lastRow As Long
Dim timestampColumn As Long
Dim fileLogColumn As Long
Dim i As Long
Dim strbody As String
Dim receiverName As String
Dim myMessage As String
Dim reportNameRange As String
Dim answerConfirmation As Variant
Application.ScreenUpdating = False
Set sh = Sheets("Report sender")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)
lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
i = 0
reportNameRange = "C1:E1"
timestampColumn = 17 'based on offset on EmailCell (column B)!
fileLogColumn = 18 'based on offset on EmailCell (column B)!
myMessage = "Are you sure you want to send weekly reports?" & vbNewLine & "'" & _
sh.Range("C2").Value & "', " & vbNewLine & "'" & sh.Range("D2").Value & "' and " & vbNewLine & _
"'" & sh.Range("E2").Value & "'?"
answerConfirmation = MsgBox(myMessage, vbYesNo, "Send emails")
If answerConfirmation = vbYes Then
GoTo Start
End If
If answerConfirmation = vbNo Then
GoTo Quit
End If
Start:
For Each EmailCell In sh.Range("B3:B" & lastRow)
EmailCell.Offset(0, fileLogColumn).ClearContents
EmailCell.Offset(0, timestampColumn).ClearContents
Set rng = sh.Cells(EmailCell.Row, 1).Range(reportNameRange)
If EmailCell.Value Like "?*#?*.?*" And Application.WorksheetFunction.CountA(rng) > 0 Then
With OutMail
For Each FileCell In rng
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then 'checks if there's a file path in the cell
.Attachments.Add FileCell.Value
EmailCell.Offset(0, fileLogColumn).Value = EmailCell.Offset(0, fileLogColumn).Value & ", " & _
Dir(FileCell.Value)
i = i + 1
End If
End If
Next FileCell
receiverName = EmailCell.Offset(0, -1).Value
strbody = "<BODY style=font-size:11pt;font-family:Calibri><p>Dear " & receiverName & ",</p>" & _
"<p>Please find attached the weekly reports.</p>" & _
"<p>Kind regards,</p></BODY>"
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = EmailCell.Value
.Subject = "Weekly Reporting – " & UCase("w") & "eek " & Format(Date, "ww") _
& " " & UCase(Left(Format(Date, "mmmm"), 1)) & Right(Format(Date, "mmmm"), _
Len(Format(Date, "mmmm")) - 1) & " " & Year(Now)
.display
.HTMLBody = strbody & .HTMLBody
.Send
EmailCell.Offset(0, timestampColumn).Value = Now
SkipEmail:
End With
Set OutMail = Nothing
End If
Next EmailCell
Set OutApp = Nothing
Application.ScreenUpdating = True
Call MsgBox("Weekly reports have been sent.", vbInformation, "Emails sent")
Quit:
End Sub
Appears .GetInspector has the same functionality of .Display except the "display".
Sub generateDefaultSignature_WithoutDisplay()
Dim OutApp As Object ' If initiated outside of Outlook
Dim OutMail As Object
Dim strbody As String
Dim receiverName As String
receiverName = const_meFirstLast ' My name
strbody = "<BODY style=font-size:11pt;font-family:Calibri><p>Dear " & receiverName & ",</p>" & _
"<p>Please find attached the weekly reports.</p>" & _
"<p>Kind regards,</p></BODY>"
Set OutApp = CreateObject("Outlook.Application") ' If initiated outside of Outlook
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
.To = const_emAddress ' My email address
.Subject = "Weekly Reporting – " & UCase("w") & "eek " & Format(Date, "ww") _
& " " & UCase(Left(Format(Date, "mmmm"), 1)) & Right(Format(Date, "mmmm"), _
Len(Format(Date, "mmmm")) - 1) & " " & Year(Now)
' Default Signature
' Outlook 2013
' There is a report that .GetInspector is insufficient
' to generate the signature in Outlook 2016
'.GetInspector ' rather than .Display
' Appears mailitem.GetInspector was not supposed to be valid as is
' .GetInspector is described here
' https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.getinspector
Dim objInspector As Inspector
Set objInspector = .GetInspector
.HTMLBody = strbody & .HTMLBody
.Send
End With
ExitRoutine:
Set OutApp = Nothing
Set OutMail = Nothing
End Sub

Modify email sending macro to include attachment

I would like to modify this script to include an attachment in the email that it creates. Cell F5 on worksheet "Instructions" contains the file path. I've tried to modify it using information from several different sources.
Here is a working version, pre-attachment attempts:
Sub CreateMails()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As String
Dim rngAttach As Range
Dim SigString As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With Worksheets("Data validation")
Set rngTo = .Range("J63")
Set rngSubject = .Range("J61")
strbody = "One time vendor number request." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & vbNewLine & _
"__________________________________" & vbNewLine & _
.Range("J67") & vbNewLine & vbNewLine & _
"My Company" & vbNewLine & _
"123 Address street" & vbNewLine & _
"City, State, Zip, USA" & vbNewLine & _
"Telephone:"
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.Save
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set strbody = Nothing
Set rngAttach = Nothing
End Sub
All you should need is:
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = strbody
.attachments.Add Range("F5").Value 'add the attachment
.Save
End With
Using your code, this worked for me.
Hi I can share the below template code which i use for creating and attaching a sheet from my workbook as a PDF _ i've changed some of the "text" values but the rest is the same.
You could work with this to include the attachment, and send as xlsx if required.
Sub SendWorkSheetToPDF()
Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim SH As Worksheet
Dim cell As Range
Dim strto As String
Dim Strcc As String
Application.ScreenUpdating = False
'To'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("A2:A15")
If cell.Value Like "?*#?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
On Error Resume Next
'CC'
For Each cell In ThisWorkbook.Sheets("Mail_addresses").Range("B2:B15")
If cell.Value Like "?*#?*.?*" Then
Strcc = Strcc & cell.Value & ";"
End If
Next cell
If Len(Strcc) > 0 Then Strcc = Left(Strcc, Len(Strcc) - 1)
On Error Resume Next
Set Wb = Application.ActiveWorkbook
FileName = "afilename"
xIndex = VBA.InStrRev(FileName, ".")
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = strto
.CC = Strcc
.BCC = ""
.Subject = "subject text"
.Body = "All," & vbNewLine & vbNewLine & _
"Please see attached daily " & vbNewLine & vbNewLine & _
"Kind Regards" & vbNewLine & _
" "
.Attachments.Add FileName
.Send
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
MsgBox "Email Sent"
End Sub

Resources