How to Attach Files with Dates in VBA - vba

I have a macro that generates emails but I want to make this macro attach specific files with a date.
The date I want the macro to find when searching for the files is this:
lastSunday = DateAdd("d", 1 - Weekday(Now), Now)
Format(lastSunday, "dd-MM-yyyy")
Here is my full Macro:
Sub macro()
Dim OutApp As Object, OutMail As Object
Dim emailTo As String, emailCC As String
Dim lastSunday As Date
Dim c As Range
lastSunday = DateAdd("d", 1 - Weekday(Now), Now)
emailTo = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Table22[To]"))
emailCC = WorksheetFunction.TextJoin(";", True, ActiveSheet.Range("Table22[CC]"))
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = emailTo
.CC = emailCC
.Subject = "Weekly Reports - " & Format(lastSunday, "dd-MM-yyyy")
.Body = "Dear all," & vbCrLf & vbCrLf & _
"Please find attached the Weekly report" & vbCrLf & vbCrLf & "Hope this helps, please let me know if you require any additional detail." & vbCrLf & vbCrLf & "Kind regards,"
'.Attachments.Add "S:documents\[filename - DD-mm-YYYY]"
OutMail.Display
End With
End Sub

The Attachments.Add method creates a new attachment in the Attachments collection. The source of the attachment can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment. So, you need to be sure the file doesn't contain forbidden symbols (it is a valid filename) and the file is located locally, for example:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = emailTo
.CC = emailCC
.Subject = "Weekly Reports - " & Format(lastSunday, "dd-MM-yyyy")
.Body = "Dear all," & vbCrLf & vbCrLf & _
"Please find attached the Weekly report" & vbCrLf & vbCrLf & "Hope this helps, please let me know if you require any additional detail." & vbCrLf & vbCrLf & "Kind regards,"
.Attachments.Add "S:\documents\filename - " & Format(lastSunday, "dd-MM-yyyy") & ".ext"
OutMail.Display
End With

Related

Hyperlink stops at spaces in FilePath in VBA

I want to give a Hyperlink to a sharedrive path in eMail generated through VBA. In my excel, mail distribution list, mail subject & file path are dynamic hence VBA is picking these details from that particular cell. Since FilePath has 'space', hyperlink is not taking the entire path. Kindly see my code below and let me know where am I wrong-
Sub Draft_Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim Filepath As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Filepath = Worksheets("Macro").Range("F7")
With OutMail
.To = Worksheets("Macro").Range("F9").Text
.Cc = Worksheets("Macro").Range("F11").Text
.Subject = Worksheets("Macro").Range("F13").Text
.Attachments.Add Filepath
.htmlBody = "Hello-" & "<br/>" & "<br/>" & "Please find attached Reconciliation for " & Worksheets("Macro").Range("F5").Text & ". Click on this link to open the file- " & "<br/>" & "<br/>" & "" & Filepath & "" & "<br/>" & "<br/>" & "Regards"
.Display
End With
End Sub
The href will need to be within quotes, like this...
"<A href='" & Filepath & "'>" & Filepath & "</A>"
Alternatively, you can replace any spaces in the file path with the url-encoded version %20 like this...
"" & FilePath & ""

Runtime Error - Cannot find this file; verify name & file path correct (Excel / VBA)

Running into error message in title when attempting to link attachments to email. The attachments are stored in Folder Names respective to the "type" of company, which is why I'm attempting to add a for loop to retrieve "type" from spreadsheet.
Sub mailTest()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olAttachmentLetter As Outlook.Attachments
Dim fileLocationLetter As String
Dim dType As String
For i = 2 To 3
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachmentLetter = olMail.Attachments
fileLocationLetter = "C:\...\user\Desktop\FileLocation"
letterName = "TestLetter1"
dType = Worksheets("Test1").Cells(i, 2).Value
mailBody = "Hello " _
& Worksheets("Test1").Cells(i, 4) _
& "," _
& Worksheets("BODY").Cells(2, 1).Value _
& Worksheets("BODY").Cells(3, 1).Value _
& Worksheets("BODY").Cells(4, 1).Value & " " & dType _
& Worksheets("BODY").Cells(5, 1).Value & " TTT" & dType & "xx18" _
& Worksheets("BODY").Cells(6, 1).Value _
& Worksheets("BODY").Cells(7, 1).Value
With olMail
.To = Worksheets("Test1").Cells(i, 5).Value
.Subject = Worksheets("Test1").Cells(i, 3).Value & " - "
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 13px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
''Adding attachment
.Attachments.Add fileLocationLetter & letterName & ".pdf"
.Display
'' .Send (Once ready to send)
End With
Set olMail = Nothing
Set olApp = Nothing
Next
End Sub
What am I doing wrong here? The file is stored in 'C:...\user\Desktop\FileLocation\TestLetter1.pdf'
Thank you kindly.
You are missing the \ between the fileLocation and the letterName. Thus, either write this:
.Attachments.Add fileLocationLetter & "\" & letterName & ".pdf"
or this:
fileLocationLetter = "C:\...\user\Desktop\FileLocation\"
With much help from #Vityata, figured it out.
Essentially being able to make two attachments, one is static with known file name, the second attachment's name is dependent on stored cell value. The workaround was to break the path/name of the file as stored strings. Maybe there's an easier way, but this worked for me!
Code used:
Sub mailTest()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
'' Identify Attachments
Dim olAttachmentLetter As Outlook.Attachments
Dim olAttachmentSSH As Outlook.Attachments
'' Identify Attachment Locations / Paths
Dim fileLocationLetter As String
Dim fileLocationSSH As String
Dim fileLocationSSHi As String
Dim fileLocationSSHii As String
'' Type Variable, referencing cell in worksheet where "Type" is stored (in loop below)
Dim dType As String
'' Creating the loop - Replace 4 with end of rows. Will eventually create code to automatically identify the last cell with stored value
For i = 2 To 4
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachmentLetter = olMail.Attachments
Set olAttachmentSSH = olMail.Attachments
''File Location for Letter
fileLocationLetter = "C:\...\Directory"
''File Location for Excel sheet - Need 3 fields as file name is dynamic based on loop value
fileLocationSSH = "C:\...\Directory\Excel Files"
fileLocationSSHi = "Beginning of File name..."
fileLocationSSHii = " ... End of File name"
letterName = "Name of PDF attachment"
dType = Worksheets("Test1").Cells(i, 2).Value
''Body of Email - Each new line represents new value (linking to hidden worksheet in Excel doc)
mailBody = "Hello " _
& Worksheets("Test1").Cells(i, 4) _
& "," _
& Worksheets("BODY").Cells(2, 1).Value _
& Worksheets("BODY").Cells(3, 1).Value _
& Worksheets("BODY").Cells(4, 1).Value & " " & dType _
& Worksheets("BODY").Cells(5, 1).Value _
& Worksheets("BODY").Cells(6, 1).Value _
& Worksheets("BODY").Cells(7, 1).Value
With olMail
.To = Worksheets("Test1").Cells(i, 5).Value
.Subject = Worksheets("Test1").Cells(i, 3).Value
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 13px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
'' Adding attachments, referencing file locations and amending file name if needed
.Attachments.Add fileLocationLetter & "\" & letterName & ".pdf"
.Attachments.Add fileLocationSSH & "\" & dType & "\" & fileLocationSSHi & dType & fileLocationSSHii & ".xlsx"
.Display
'' .Send (Once ready to send)
End With
Set olMail = Nothing
Set olApp = Nothing
Next
End Sub

How to insert an existing signature block into Outlook .htmlbody from Word VBA [duplicate]

This question already has answers here:
How to add default signature in Outlook
(15 answers)
Closed 6 years ago.
I have completed this code to populate the body of an Outlook email, however, I do not know how I can use my existing signature block already created in Outlook. When I create a new, reply or forward email, my signature is there, but when I create the email with this code it does not appear. What I'm trying to accomplish here is to have my signature (or any signature for that matter) appear into the email created by this code.
Private Sub emailbutton_Click()
'No-option email sending
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
If VName.Value = "" Then
Doc.SaveAs ("Quotation_Blank 2016")
Else
Doc.SaveAs2 ("QFORM" & "_" & JNumber.Value & "_" & VName.Value)
End If
With EmailItem
.Subject = "QFORM" & "_" & JNumber.Value & "_" & VName.Value
'HTMLbody
msg = "<b><font face=""Times New Roman"" size=""3"" color=""blue"">INTEGRATED ASSEMBLY </font></b><br>" _
& " 1200 Woodruff Rd.<br>" _
& " Suite A12<br>" _
& " Greenville, SC 29607<br><br>" _
& "We have recently released subject project, which will contain assemblies to be outsourced. You have been selected to build these assemblies according to the attachment.<br><br>" _
& "As part of this process, please review the quotion form attached and inidcate your acceptance. If adjustments and-or corrections are required please feel free to contact us for quick resolution.<br><br>" _
& "<b><font face=""Times New Roman"" size=""3"" color=""Red"">NOTE: </font></b>" _
& "The information on attached quotation form is not a contract and only an estimate of predetermined costs per hourly rate for outsource assemblies. <br><br>" _
& "*******For your records you may wish to print out the completed quote form. <br><br>" _
& "Thank you, <br><br>" _
& "<b>HARTNESS INTERNATIONAL </b><br>" _
& "H1 Production Control" & vbNewLine & Signature
.HTMLBody = msg
If VName.Value = "INTEGRATED ASSEMBLY" Then
.To = "XXX.com;"
.CC = "XXX.com;" & "XXX.com;"
.Importance = olImportanceNormal 'Or olImportanceHigh Or olImportanceLow
.Attachments.Add Doc.FullName
.Display
ElseIf VName.Value = "LEWALLEN" Then
.To = "XXX.com;"
.CC = "XXX.com;" & "XXX.com;"
.Importance = olImportanceNormal 'Or olImportanceHigh Or olImportanceLow
.Attachments.Add Doc.FullName
.Display
End If
End With
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub
I think you need to call the .HTMLBody again after you insert msg.
So for example:
.HTMLBody = msg & .HTMLBody
Should get the signature. I'm not deep enough into programming to know why though.
Do you have Option Explicit set in your module?
I don't see where you've set Signature or declared it so it's probably empty and not giving you an error message.
I think you need to retrieve it first by pulling in the blank Body
Something like this should work
With EmailItem
.Display
signature = .body
.Subject = "QFORM" & "_" & JNumber.Value & "_" & VName.Value
' and so on ..
`
The code was successful with inputting a with statement to display the EmailItem - along with recalling .HTMLBody following the msg.. Please see full code below.
Private Sub emailbutton_Click()
'No-option email sending
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
With EmailItem
.Display
End With
Signature = EmailItem.body
With EmailItem
.Subject = "QFORM" & "_" & JNumber.Value & "_" & VName.Value
'HTMLbody
msg = "<b><font face=""Times New Roman"" size=""4"" color=""blue"">INTEGRATED ASSEMBLY </font></b><br>" _
& " 1200 Woodruff Rd.<br>" _
& " Suite A12<br>" _
& " Greenville, SC 29607<br><br>" _
& "We have recently released subject project, which will contain assemblies to be outsourced. You have been selected to build these assemblies according to the attachment. <br><br>" _
& "As part of this process, please review the quotation form attached and indicate your acceptance. If adjustments and-or corrections are required, please feel free to contact us for quick resolution. <br><br>" _
& "<b><font face=""Times New Roman"" size=""4"" color=""Red"">NOTE: </font></b>" _
& "The information on attached quotation form is not a contract and only an estimate of predetermined costs per hourly rate for outsource assemblies. <br><br>" _
& "*******For your records you may wish to print out the completed quote form. <br><br>" _
& "Thank you, <br><br>" _
& "<b>HARTNESS INTERNATIONAL </b><br>" _
& "H1 Production Control <br>" _
& vbNewLine & Signature
.HTMLBody = msg & .HTMLBody
If VName.Value = "INTEGRATED ASSEMBLY" Then
.To = "ryan#integratedassembly.com;"
.CC = "jfournier#hartness.com;" & "jmarshone#hartness.com;"
.Importance = olImportanceNormal 'Or olImportanceHigh Or olImportanceLow
.Attachments.Add Doc.FullName
.Display
ElseIf VName.Value = "LEWALLEN" Then
.To = "jessica.andrews#patriot-automation.com;"
.CC = "jfournier#hartness.com;" & "jmarshone#hartness.com;"
.Importance = olImportanceNormal 'Or olImportanceHigh Or olImportanceLow
.Attachments.Add Doc.FullName
.Display
End If
End With
If VName.Value = "" Then
Doc.SaveAs ("Quotation_Blank 2016")
Else
Doc.SaveAs2 ("QFORM" & "_" & JNumber.Value & "_" & VName.Value)
End If
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
End Sub

"Save As" document link won't open, with error message ".. can't find .. correct location or web address"

I have an Excel Document in a Template. Users input information and Save As a new genericized number. They then hit a button that auto populates an email to one of 5 people using Vlookup and based on the cost margin.
The file is Save As'd but the e-mail recipient cannot open the file, it reads invalid location. I can close and reopen the new renamed sheet and drag it into an e-mail. I need to link to the newly saved file's name that appears in the email.
Sub Email_created_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim Mess As Object, Recip
Recip = [Sheet1!B28].Value & "; " & [Sheet1!B27].Value
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Hello,<br><br>" & _
"There is a New PO awaiting your approval :<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to Workbook</A>" & _
"<br><br>Regards," & _
"<br><br>Automated Approval System</font>"
On Error Resume Next
With OutMail
.To = Recip
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.HTMLBody = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
End Sub
The file name does adapt in my e-mail, from PO Template, but will not open.
I believe this will help you with your current issue (closing and reopening your file before sending). I've removed the the two lines of your code where you set the Outlook objects to Nothing. To reopen the current file you can use the OnTime function like so:
Sub Email_created_Workbook()
Dim OutApp As Object
Dim OutMail As Object
Dim Mess As Object, Recip
Recip = [Sheet1!B28].Value & "; " & [Sheet1!B27].Value
Dim strbody As String
If ActiveWorkbook.Path <> "" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Hello,<br><br>" & _
"There is a New PO awaiting your approval :<br><B>" & _
ActiveWorkbook.Name & "</B> is created.<br>" & _
"Click on this link to open the file : " & _
"<A HREF=""file://" & ActiveWorkbook.FullName & _
""">Link to Workbook</A>" & _
"<br><br>Regards," & _
"<br><br>Automated Approval System</font>"
On Error Resume Next
With OutMail
.To = Recip
.CC = ""
.BCC = ""
.Subject = ActiveWorkbook.Name
.HTMLBody = strbody
.Display 'or use .Send
End With
Application.OnTime Now + TimeValue("00:00:10"), "SendEmail"
ThisWorkbook.Close True 'True= yes, save changes
Else
MsgBox "The ActiveWorkbook does not have a path, Save the file first."
End If
End Sub
Sub SendEmail()
Dim OutApp As Object: Set OutApp = GetObject(, "Outlook.Application") 'Grab current instance of Outlook since we already opened the instance prior to restarting Excel
Dim oInspector As OutApp.Inspector: Set oInspector = OutApp.ActiveInspector
Dim NewMail As OutApp.MailItem: Set NewMail = oInspector.CurrentItem 'Grab currently open New/Compose Mail window
NewMail.Send 'Send Email
End Sub
Let me know if this helps resolve your issue.

Runtime error if contact in Outlook doesn't exist

When I complete a piece of work I email it to certain people. It depends on the work who gets it.
If any person in the list leaves, changes job or has an email change the code will bug out saying
Run Time error -2147467259(80004005), Outlook Does Not Recognise One Or More Names
If I manually copy the email addresses in the list and pop them into Outlook and send I'll get an email back saying the user doesn't exist or has been changed.
I have tried On Error Resume Next and On Error Goto. I have added MS Outlook 14.0 Object Libary, SharePoint Social Provider, Social Provider Extensibility and Outlook View control from the references.
The code bugs out on the .send
Sub EMailer()
Application.ScreenUpdating = False
strfilepath = "\\DFZ70069\Data\199711009\workgroup\Res Plan Team\Performance Management\Specialised Reporting\Debit & Credit Reporting\Masters\Sent Reports\"
strArea = "Recipients" '..........................................................................................
'Get list of recipients for email
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value = "" Then GoTo Continue
strmaillist = strmaillist & cell.Value + ";"
Continue:
Next
[B1].Value = strmaillist
If bMyEmail = True Then
strmaillist = strmaillist & MyEmailAddress
End If
'Display email list
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Sending " & sReportName & " emails to " & vbNewLine & strArea, _
AckTime, "Message Box", 0)
Case 1, -1
End Select
'SEND EMAIL
'set up Body of email............
strbody = "Please find attached " & sReportName & " Report " & " _" & strDate & vbLf & vbLf & _
strComments & vbLf & _
strComments2 & vbLf & _
"" & vbLf & _
eMailName & vbLf & _
"MI & Performance Reporting Team" & vbLf & _
sline2 & vbLf & _
sline3 & vbLf & vbLf & _
sLine4
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = strmaillist
.CC = ""
.BCC = ""
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
.send ' bugs out here
End With
Set OutMail = Nothing
Set OutApp = Nothing
ThisWorkbook.Activate
Sheets("Sheet1").Select
Application.ScreenUpdating = True: Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range(sRange2).Value = sConclusion '.
Application.ScreenUpdating = True: Application.ScreenUpdating = False
End Sub
You can try to check the validity of the recipient before sending, by using the .Resolve method of the Recipient object. Only valid recipients can be kept in the Recipient list of the mail item.
You might try this:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value <> "" Then
set r = .Recipients.Add(cell.value)
If Not r.Resolve then r.Delete '<~~ Removes invalid recipients
End If
Next
.send
End With