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 & ""
Related
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
From last week till now, I have a several question here to did the mini project send email with attachment by Excel VBA. Now I'm stucking in the final step.
My project is send email with the proper attachment (stored in the specific folder). something like this:
Here is my code:
Sub SendEmail_Example1()
' email processing
For i = 2 To Sheet2.Range("A" & Rows.Count).End(xlUp).Row
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = Sheet2.Range("D" & i).Value
'EmailItem.CC = "hello#gmail.com"
'EmailItem.BCC = "hhhh#gmail.com"
EmailItem.Subject = "User info of " & Sheet2.Range("D" & i).Value
EmailItem.HTMLBody = "Hi, below is your user info " & "<br>" & "User is: " & Sheet2.Range("B" & i).Value & "<br>" & _
"Password is : " & vbNewLine & Sheet2.Range("C" & i).Value & _
vbNewLine & vbNewLine & _
"<br>" & "Regards," & _
"<br>" & "VT"
'Source = ThisWorkbook.FullName
'---------Attachment
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim file As file
Dim folder As folder
Set folder = fso.GetFolder("C:\test")
'Source = "C:\test"
For Each file In folder.Files
If Sheet1.Range("A" & i).Value = file.Name Then
EmailItem.Attachments.Add file.Name
Exit For
End If
Next file
EmailItem.Send
Next i
End Sub
I would like to grab the proper attachment with each outgoing email, that mean the email send to user named "jack" will get the attach named "jack.xlsx"
Could you please help assist on this issue ? Appriciated much for all the support
There are 2 issues with FSO/Attachment portion of your code:
file.Name will return the file with the extension which will not match the value in your Column A so you need to use fso.GetBaseName to get the file name without the extension.
You need to provide the full path of the file to add attachment so use file.Path instead of file.Name.
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim file As file
Dim folder As folder
Set folder = fso.GetFolder("C:\test")
'Source = "C:\test"
For Each file In folder.Files
If Sheet1.Range("A" & i).Value = fso.GetBaseName(file.Name) Then
EmailItem.Attachments.Add file.Path
Exit For
End If
Next file
EmailItem.Send
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
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
In reference to the below code, what I am looking to do is rather than process an entire folder I would like only to process the emails that I selected.
Otherwise it works perfectly.
Jeff
Requires the following references:
Visual Basic for Applications
Microsoft Outlook 14.0 Object Library
OLE Automation
Microsoft Office 14.0 Object Library
Microsoft Shell Controls and Automation
Public Sub SaveOLFolderAttachments()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim sSavePathFS As String
Dim sDelAtts As String
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection. The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each style loops will not work. ~~
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method which
' will decrement msg.Attachments.Count by one each time. ~~
While msg.Attachments.Count > 0
' Save the attachment to the file system
sSavePathFS = fsSaveFolder.Self.path & "\" & msg.Attachments(1).filename
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior. ~~
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted. ~~
msg.Save
End If
Next
End Sub
Drop the pickfolder code and select the items first.
' http://msdn.microsoft.com/en-us/library/office/aa171941(v=office.11).aspx
Untested code
Sub SaveOLSelectedItemsAttachments()
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim x As Integer
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
For x = 1 To myOlSel.Count
' Iteration variables
Dim att As Outlook.Attachment
Dim sSavePathFS As String
Dim sDelAtts As String
Dim msg as mailitem
Set msg = myOlSel.Item(x)
sDelAtts = ""
' We check the item for attachments.
' The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each style loops will not work. ~~
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method which
' will decrement msg.Attachments.Count by one each time. ~~
While msg.Attachments.Count > 0
' Save the attachment to the file system
sSavePathFS = fsSaveFolder.Self.path & "\" & msg.Attachments(1).filename
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior. ~~
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted. ~~
msg.Save
End If
Next
Next x
End Sub