Adding default signature, that consists of images, in Outlook using Excel VBA - excel

I want to add signatures with images. Images here refer to company logo and social networking icons.
This code is written in Excel VBA and the goal is to copy paste the range as a picture in Outlook email.
Dim Rng As Range
Dim outlookApp As Object
Dim outMail As Object
Dim wordDoc As Word.Document
Dim LastRow As Long
Dim CcAddress As String
Dim ToAddress As String
Dim i As Long
Dim EndRow As String
Dim Signature As String
'// Added Microsoft word reference
Sub Excel_Image_Paste_Testing()
On Error GoTo Err_Desc
'\\ Define Endrow
EndRow = Range("A65000").End(xlUp).Row
'\\ Range for copy paste as image
Set Rng = Range("A22:G" & EndRow)
Rng.Copy
'\\ Open a new mail item
Set outlookApp = CreateObject("Outlook.Application")
Set outMail = outlookApp.CreateItem(0)
'\\ Display message to capture signature
outMail.Display
'\\ This doesnt store images because its defined as string
'Problem lies here
Signature = outMail.htmlBody
'\\ Get its Word editor
Set wordDoc = outMail.GetInspector.WordEditor
outMail.Display
'\\ To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
'\\ TO and CC Address
CcAddress = "xyz#gmail.com"
ToAddress = "abc#gmail.com"
'\\ Format email
With outMail
.htmlBody = .htmlBody & Signature
.Display
.To = ToAddress
.CC = CcAddress
.BCC = ""
.Subject = "Email Subject here"
.readreceiptrequested = True
End With
'\\ Reset selections
Application.CutCopyMode = False
Range("B1").Select
Exit Sub
Err_Desc:
MsgBox Err.Description
End Sub
This file is to be distributed to many people. I wouldn’t know the default .htm signature name.
(“AppData\Roaming\Microsoft\Signatures”)
People may also have many signatures but my goal is to capture their default signature.
Error signature picture after running the code
My signature should be as shown below.

In this code we will let the user select the .Htm file from AppData\Roaming\Microsoft\Signatures
The problem is that we cannot directly use the html body of this file because the images are stored in a different folder named as filename_files as shown below.
Also the paths mentioned in the htmlbody are incomplete. See the below images
Here is a quick function that I wrote which will fix the paths in the html body
'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
Dim FullPath As String, filename As String
Dim FilenameWithoutExtn As String
Dim foldername As String
Dim MyData As String
'~~> Read the html file as text file in a string variable
Open r For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
'~~> Get File Name from path
filename = GetFilenameFromPath(r)
'~~> Get File Name without extension
FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
'~~> Get the foldername where the images are stored
foldername = FilenameWithoutExtn & "_files"
'~~> Full Path of Folder
FullPath = Left(r, InStrRev(r, "\")) & foldername
'~~> Replace incomplete path with full Path
FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function
Here is the complete procedure. I have commented the code. Let me know if you still have any issues.
Sub Sample()
Dim oOutApp As Object, oOutMail As Object
Dim strbody As String, FixedHtmlBody As String
Dim Ret
'~~> Ask user to select the htm file
Ret = Application.GetOpenFilename("Html Files (*.htm), *.htm")
If Ret = False Then Exit Sub
'~~> Use the function to fix image paths in the htm file
FixedHtmlBody = FixHtmlBody(Ret)
Set oOutApp = CreateObject("Outlook.Application")
Set oOutMail = oOutApp.CreateItem(0)
strbody = "<H3><B>Dear Blah Blah</B></H3>" & _
"More Blah Blah<br>" & _
"<br><br><B>Thank you</B>" & FixedHtmlBody
On Error Resume Next
With oOutMail
.To = "Email#email.com" '<~~ Change as applicable
.CC = ""
.BCC = ""
.Subject = "Example on how to insert image in signature"
.HTMLBody = .HTMLBody & "<br>" & strbody
.Display
End With
On Error GoTo 0
Set oOutMail = Nothing
Set oOutApp = Nothing
End Sub
'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
Dim FullPath As String, filename As String
Dim FilenameWithoutExtn As String
Dim foldername As String
Dim MyData As String
'~~> Read the html file as text file in a string variable
Open r For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
'~~> Get File Name from path
filename = GetFilenameFromPath(r)
'~~> Get File Name without extension
FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
'~~> Get the foldername where the images are stored
foldername = FilenameWithoutExtn & "_files"
'~~> Full Path of Folder
FullPath = Left(r, InStrRev(r, "\")) & foldername
'~~> To cater for spaces in signature file name
FullPath = Replace(FullPath, " ", "%20")
'~~> Replace incomplete path with full Path
FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function
'~~> Gets File Name from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End Function
In Action

Related

Excel VBA PDF attachment sometimes sending as SharePoint link instead of attaching the file

I've got a simple VBA function that sends an email with an attached PDF. About every 50 or times the code is called, instead of attaching the PDF, it sends a link to the file where it's saved in SharePoint. Has anyone else ever seen this behavior and has an answer for why it occasionally send a link to the file instead of the actual file?
Sub SendEmail()
Dim rng As Range, c As Range
Dim nRow As Integer
Dim rw As ListRow
Dim Emails As String
Dim Outlook As Object
Dim OutlookMail As Object
'Send report via Outlok
Set Outlook = CreateObject("Outlook.Application")
Set OutlookMail = Outlook.CreateItem(0)
With OutlookMail
.To = "Red-Scheduling"
.CC = ""
.BCC = ""
.Subject = "Schedules - " & Format(ActiveSheet.Range("ScheduleDate"), "mm/dd/yyyy")
.htmlbody = RangetoHTML(Worksheets("Schedule").Range("EmailReport"))
.Attachments.Add PDFActiveSheet
.Display
End With
End Sub
Function PDFActiveSheet() As String
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errExit
Set wbA = ActiveWorkbook
strTime = Format(Range("ScheduleDate").Value2, "mm-dd-yyyy")
'get active workbook folder, if saved
strPath = "https://****.sharepoint.com/sites/RedmondShared/Shared%20Files/Schedules/"
'replace spaces and periods in sheet name
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
Range("EmailReport").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strPathFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
PDFActiveSheet = strPathFile
exitSub:
Exit Function
errExit:
MsgBox "Could not create PDF file"
PDFActiveSheet = ""
Resume exitSub
End Function

Excel VBA attach multiple PDFs to an email - my do loop skips first PDF for second and subsequent emails generated?

I have attempted to write a macro that scans through a folder to pick relevant PDFs belonging to a person (such as AAA) and attach them to an email to be sent to AAA, then move on to pick up PDFs belonging to BBB and attach them to an email to be sent to BBB so on and so forth. My folder containing the PDFs looks like this:
AAA_111111.pdf
AAA_222222.pdf
AAA_333333.pdf
BBB_111111.pdf
BBB_222222.pdf
BBB_333333.pdf
CCC_777777.pdf
CCC_888888.pdf
CCC_999999.pdf
CCC_444444.pdf
The person is identified by the letters before the underscore (initials) and there is a list on another Excel tab that the initials are looked up against to return their email address.
I have written the code below and it works fairly well except it has an irritating flaw that I cannot solve. It will successfully generate the email for person AAA and attach all three files listed above for them. On the next pass of the main (outer) "do while" loop it comes to person BBB but the inner "do while mfe=" loop attaches the second and third file listed for them (BBB_222222.pdf & BBB_333333.pdf) and completely ignores BBB_111111.pdf (doesn't attach it) though it seems to be able to see it on. Ditto for the third loop, the "do while mfe=" loop will attach the latter three files for CCC to an email but won't attach CCC_777777.pdf?!
Sub emailreports()
Dim OutApp As Object
Dim OutMail As Object
Dim OMail As Object, signature, mfe, sto As String
Dim emaillastrow, x, a As Long
Dim fso As Scripting.FileSystemObject
Set fso = New FileSystemObject
Dim folder, strfile As String
Dim rundate As Date
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.AutoRecover.Enabled = False
folder = Worksheets("START").Range("A14")
strfile = Dir(folder)
rundate = Worksheets("TEMPLATE").Range("E7")
b = Worksheets("START").Range("H25")
Sheets("EMAIL").Select
emaillastrow = Worksheets("EMAIL").Range("A1000000").End(xlUp).Row
If Dir(folder, vbDirectory) = "" Then
MsgBox "PDF destination file path doesn't exist.", vbcritial, "Path error"
Exit Sub
End If
Do While Len(strfile) > 0
Filename = fso.GetBaseName(folder & strfile)
mfe = Left(Filename, InStr(Filename, "_") - 1)
For x = 2 To emaillastrow
If mfe = Worksheets("EMAIL").Range("A" & x) Then
sto = sto & ";" & Worksheets("EMAIL").Range("B" & x)
End If
Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
End With
With OutMail
.To = LCase(sto)
.CC = ""
.BCC = ""
.Subject = "Test subject text"
Do While mfe = Left(Filename, InStr(Filename, "_") - 1)
.Attachments.Add (folder & Filename)
Filename = Dir
If Filename = "" Then
Exit Do
End If
Loop
.signature.Delete
.HTMLBody = "<font face=""arial"" style=""font-size:10pt;"">" & "Test email body text" & .HTMLBody
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set OutAccount = Nothing
Skip:
sto = ""
strfile = Filename
Loop
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.AutoRecover.Enabled = True
End Sub
I thought about trying to make it somehow at the end of generating the email to take a step back but being a Do loop this is not possible. My code seems to ignore the PDF that it stopped at as part of the previous email generation and when generating the next email starts from that PDF file but only picks up and attaches subsequent PDFs. Any help would be gratefully received as I've tried all sort of things but can't make it work. This is my first post to Stackoverflow so apologies if my question and/or format is not correct or appropriate.
You could use a dictionary object to group together the filenames by prefix with one pass of the directory and then iterate the dictionary keys to create the emails with corresponding attachments. For example (outlook methods untested)
Option Explicit
Sub emailreports()
Dim dict As Scripting.Dictionary, key
Set dict = New Scripting.Dictionary
Dim folder As String, strfile As String, mfe As String
Dim sTo As String, arPDF, arAddr, f
Dim ws As Worksheet, r As Long, emaillastrow As Long
folder = Worksheets("START").Range("A14")
strfile = Dir(folder & "*.pdf")
If strfile = "" Then
MsgBox "PDF destination file path doesn't exist.", vbCritical, "Path error " & folder
Exit Sub
Else
' group files by prefix
Do While strfile <> ""
mfe = Left(strfile, InStr(strfile, "_") - 1)
If dict.Exists(mfe) Then
dict(mfe) = dict(mfe) & vbTab & strfile
Else
dict.Add mfe, strfile
End If
strfile = Dir ' get next pdf
Loop
End If
Set ws = Worksheets("EMAIL")
emaillastrow = ws.Cells(Rows.Count, "A").End(xlUp).Row
' read email address lookup into array
arAddr = ws.Range("A2:B" & emaillastrow)
' prepare one email per key
Dim OutApp As Object, OutMail As Object, OMail As Object
'Set OutApp = CreateObject("Outlook.Application")
For Each key In dict.Keys
' build array of file names for one key
mfe = Trim(key)
arPDF = Split(dict(mfe), vbTab)
' get email addresses
sTo = ""
For r = 1 To UBound(arAddr)
If mfe = arAddr(r, 1) Then
sTo = sTo & arAddr(r, 2) & ";"
End If
Next
Debug.Print key, sTo
'Set OutMail = OutApp.CreateItem(0)
'With OutMail
'.To = LCase(sTo)
'.cc = ""
'.BCC = ""
'.Subject = "Test subject text"
' attach pdfs
For Each f In arPDF
'.Attachments.Add folder & f
Debug.Print , folder & f
Next
'.signature.Delete
'.HTMLBody = "<font face=""arial"" style=""font-size:10pt;"">" & "Test email body text" & .HTMLBody
'.Display
'End With
Next
'OutApp.quit
End Sub
On Error Resume Next seems to mask errors and hide skip reason. Try to use more specialized filename mask:
...
folder = Worksheets("START").Range("A14")
If Dir(folder, vbDirectory) = "" Then
MsgBox "PDF destination file path doesn't exist.", vbcritial, "Path error"
Exit Sub
End If
strfile = Dir(fso.BuildPath(folder, "*_*.pdf")
rundate = Worksheets("TEMPLATE").Range("E7")
b = Worksheets("START").Range("H25")
'Sheets("EMAIL").Select 'no need to select a sheet
emaillastrow = Worksheets("EMAIL").Range("A1000000").End(xlUp).Row
...

Pick file names stored in an Array and attach those files over email VBA

I am trying to pick files with names stored in a cell with comma separated and attached those files over email. Below is the code which I am working on and I keep on getting RunTime error 438.
I am struggling to figure out what is going wrong, your expertise would help me to resolve the issue
Private Sub test3()
Dim mess_body As String, StrFile As String, StrPath As String
Dim appOutLook As Object
Dim MailOutLook As Object
Dim i As Long
Dim Elem As Variant
Dim myArr As Variant
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
StrPath = Sheets("Input").Range("E3").Value
With MailOutLook
.To = "manoj.sahoo#gmail.com"
.Subject = "test"
.HTMLBody = "test"
With Worksheets("DL")
For i = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
myArr = Split(.Range("B" & i).Value, ",")
For Each Elem In myArr
StrFile = Dir(StrPath & "\" & Elem & ".xlsx")
'
Do While Len(StrFile) > 0
.attachments.Add StrPath & "\" & StrFile
StrFile = Dir
Loop
Next Elem
Next i
End With
'
.Display
End With
End Sub
You have two nested With operators in the code:
With MailOutLook
.To = "manoj.sahoo#gmail.com"
.Subject = "test"
.HTMLBody = "test"
With Worksheets("DL")
The Worksheet doesn't have the Attachments property. You need to explicitly use the source object in the nested With operator.
MailOutLook.attachments.Add StrPath & "\" & StrFile
Finally, make sure that you pass a valid file path to the Add method of the Attachments class. 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.

Add image (chart) to HTMLbody

I am having issues with inserting image (chart) into an HTMLbody. I export the chart to another folder and then call the image path.
msg = "<html>123,<br/> 123 <b>" & countries & ":</b><br/>" & RangetoHTML(tablex) & s & "<img src=""cid:" & fileName & "><html\>"
However, after I insert the image with the above message body it shows:
And after the adjustments by correctly specifying which image, I get:
To specify the exact image I use:
Set myChart = wbe.Sheets("Sheet1").ChartObjects("Chart 11").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.jpg"
myPath = "C:\qwe\"
fileName = myPath & myPicture
myChart.Export fileName
Whole code:
Sub transactional_emails()
'Create email and save it as draft
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim source As String
Dim oAccount As String
Dim msg As String
Dim tablex As Range
Dim wbe As Workbook
Dim las As Long
Dim countries As String
Dim myChart As Chart
countries = "LOL"
Set wbe = Workbooks(ThisWorkbook.Name)
las = wbe.Sheets("Sheet1").Cells(wbe.Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
Set tablex = wbe.Sheets("Sheet1").Range("A1:G" & las)
With tablex.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
Set myChart = wbe.Sheets("Sheet1").ChartObjects("Chart 11").Chart
Dim myPicture As String
Dim fileName As String
Dim myPath As String
myPicture = "Chart1.jpg"
myPath = "C:\qwe\"
fileName = myPath & myPicture
myChart.Export fileName
'Create the Outlook application and the empty email.
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Dim s As String
s = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(s, vbDirectory) <> vbNullString Then s = s & Dir$(s & "*.htm") Else s = ""
s = CreateObject("Scripting.FileSystemObject").GetFile(s).OpenAsTextStream(1, -2).ReadAll
msg = "<html>123,<br/> 123 <b>" & countries & ":</b><br/>" & RangetoHTML(tablex) & s & "<img src=""cid:" & myPicture & """></html>"
With olMailItm
SDest = "gal.bordelius_ext#novartis.com"
'oAccount = "customer.service_GOC#novartis.com"
.To = SDest
.CC = "gal.bordelius_ext#novartis.com"
.Subject = countries & " 123 " & Date
.Attachments.Add fileName, 1, 0
.htmlbody = msg
.Save
End With
'Clean up the Outlook application.
Set olMailItm = Nothing
Set olApp = Nothing
End sub
The source code is valid:
You attach an image to the mail item in Outlook:
.Attachments.Add fileName, 1, 0
Then you can refer to the attached image from the message body in the following way:
"<img src=""cid:" & myPicture & """>
Sometimes you also need to set the PR_ATTACH_CONTENT_ID property (DASL - http://schemas.microsoft.com/mapi/proptag/0x3712001F) on the attachment using Attachment.PropertyAccessor.
You may also consider adding some parameters like height or width. Note, the image name can't contains spaces.
When you open an email message that contains images in Microsoft Office Outlook, the image areas can be blocked. Read more about that in the Pictures cannot be displayed and are shown as red X in Outlook article.

How to save an Outlook attachment to SharePoint?

I created a function in Excel to save a specified attachment (Excel file) from a specified email to a file location.
My organisation has moved all of our files to Sharepoint. I tried to update my function using the SharePoint path, but it fails to save the attachment.
Function OpenEMailAttachment(Path As String, FileName As String, FindSubj As String, FindAttachName As String, SubFolder As Object)
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object
Dim wb As Workbook
Dim sSubj As String
'~~> Outlook Variables for email
' Other options for email properties are:
' eSender = oOlItm.SenderEmailAddress
' dtRecvd = oOlItm.ReceivedTime
' dtSent = oOlItm.CreationTime
' sMsg = oOlItm.Body
'~~> Get Outlook instance
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Store the relevant info in the variables
For Each oOlItm In oOlInb.Items
sSubj = oOlItm.Subject
Debug.Print sSubj & "-->" & FindSubj
If sSubj Like FindSubj Then
Debug.Print "Opening attachment"
If oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
'~~> Download the attachment
If oOlAtch.FileName Like FindAttachName Then
Debug.Print Path & FileName
oOlAtch.SaveAsFile Path & FileName
Debug.Print Path & oOlAtch.FileName
oOlItm.UnRead = False
DoEvents
oOlItm.Save
On Error Resume Next
oOlItm.Move SubFolder
On Error GoTo 0
End If
Next
End If
End If
Next
'~~> FilePath is the file that we earlier downloaded
Set wb = Workbooks.Open(Path & FileName)
OpenEMailAttachment = FileName
End Function
The path I specified is like https://MyOrg.sharepoint.com/teams/FolderName/
and the FileName like File%20Name.xlsx
Try this.
Sub copyFilesTo_Sharepoint()
Dim srcFolder As String
Dim dstFolder As String
' source path
srcFolder = "WriteYourSourcePathHere"
' destination path
dstFolder = "\\MyOrg.sharepoint.com\teams\FolderName"
' copies all Excel files starting with 'myfiles' with extension 'xslx'
Call fs_cpyFilesToFolder(srcFolder, dstFolder, "myfile*.xlsx")
End Sub
Sub fs_cpyFilesToFolder(srcPath As String, dstPath As String, Optional FileExt As String = "*.xlsx")
Dim fso As Object: Set fso = CreateObject("scripting.filesystemobject")
' checks if source path has a '\'
If Right(srcPath, 1) <> "\" Then
srcPath = srcPath & "\"
End If
' checks if source path exists
If fso.FolderExists(srcPath) = False Then
MsgBox srcPath & " doesn't exist"
Exit Sub
End If
' checks if destination path exists
If fso.FolderExists(dstPath) = False Then
MsgBox dstPath & " doesn't exist"
Exit Sub
End If
' copies files to sharepoint
fso.CopyFile Source:=srcPath & FileExt, Destination:=dstPath
End Sub

Resources