I have code that creates emails from Excel, and uses Ron DeBruin's method for adding the signature. It all works, and if I leave it as .display, the emails show up correctly, with the image. I had to modify the .htm file in the Outlook signature location to the full address of the image to make that work, which I learned here as well.
However, once I change the code to .send, the recipients are saying the images are blank...there is a spot for them, but they are blank boxes. If I set it to send to myself, the image arrives correctly. If I display the email first and THEN send, the recipients get the image as well. It just does not work when sending directly from within the code.
What would cause that? Do you see an error in my code? I have read that using getinspector could help but I do not understand how to do that, or how to apply it here if that indeed is a fix.
Also, I am open to not having the image be in the signature. It could just be inserted somewhere in the email...maybe even just an attachment, though embedded in the email is much preferred.
Thank you.
Option Explicit
Sub NOTIFICATIONS()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim strname As String
Dim strname1 As String
Dim strname2 As String
Dim strEmp As String
Dim previousName As String
Dim nextName As String
Dim emailWS As Worksheet
Dim nameCol As Double
Dim nameCol2 As Double
Dim empCol As Double
Dim lastCol As Double
Dim lastRow As Double
Dim startRow As Double
Dim startCol As Double
Dim r As Double
Dim sigstring As String
Dim Signature As String
Dim empList As String
' Get work signature
sigstring = Environ("appdata") & "\Microsoft\Signatures\Notifications.htm"
If Dir(sigstring) <> "" Then
Signature = GetBoiler(sigstring)
Else
Signature = ""
End If
Set OutApp = CreateObject("Outlook.Application")
Set emailWS = ActiveSheet
startRow = 2
startCol = 1
nameCol = 3
nameCol2 = 1
empCol = 5
lastRow = emailWS.Cells(emailWS.rows.Count, nameCol).End(xlUp).row
lastCol = emailWS.Cells(1, emailWS.Columns.Count).End(xlToLeft).Column
For r = startRow To lastRow
strname = (emailWS.Cells(r, nameCol2))
strname1 = Trim(Split(emailWS.Cells(r, nameCol2), ",")(1))
strEmp = emailWS.Cells(r, empCol)
If emailWS.Cells(r + 1, nameCol2) <> "" Then
nextName = (emailWS.Cells(r + 1, nameCol2))
Else
nextName = "Exit"
End If
If strname <> previousName Then
previousName = strname
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = emailWS.Cells(r, 2).value
.Subject = "Please Review Updated Information "
empList = strEmp & "<br>"
strbody = "<Font Face=calibri>Dear " & strname1 & ", <br><br> " & _
"Please review the below."
End With
Else
If InStr(empList, strEmp) = 0 Then
empList = empList & strEmp & "<br>"
End If
End If
If strname <> nextName Then
OutMail.HTMLBody = strbody & "<B>" & empList & "</B>" & "<br>" & Signature
OutMail.send
End If
If emailWS.Cells(r + 1, nameCol2) = "" Then
Exit Sub
End If
Next r
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
