How can I add the Outlook Signature to my VBA program?

[erisciveja]

Sub sendCustEmails()


Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
Dim Signature As String


intRow = 2

While (ThisWorkbook.Sheets("Client_Data").Range("A" & intRow).Text <> "")

Set objEmail = objOutlook.CreateItem(olMailItem)
strMailSubject = ThisWorkbook.Sheets("Mail_Details").Range("A2").Text
strMailBody = ThisWorkbook.Sheets("Mail_Details").Range("B2").Text

intRow = 2
strAudit = ThisWorkbook.Sheets("Client_Data").Range("A" & intRow).Text
strPrefix = ThisWorkbook.Sheets("Client_Data").Range("B" & intRow).Text
strName = ThisWorkbook.Sheets("Client_Data").Range("C" & intRow).Text
strEmail = ThisWorkbook.Sheets("Client_Data").Range("D" & intRow).Text
strAttachment = ThisWorkbook.Sheets("Client_Data").Range("E" & intRow).Text
strSignature = ThisWorkbook.Sheets("Client_Data").Range("F" & intRow).Text

strMailBody = Replace(strMailBody, "<Prefix>", strPrefix)
strMailBody = Replace(strMailBody, "<Name>", strName)
strMailBody = Replace(strMailBody, "<Audit>", strAudit)
strMailBody = Replace(strMailBody, "<Signature>", strSignature)


With objEmail
.To = CStr(strEmail)
.Subject = strMailSubject
.Body = strMailBody & Signature
.Attachments.Add strFolder & "\" & strAttachment
.Display
End With

intRow = intRow + 1

Wend

MsgBox "Done"

End Sub


This code currently displays an Outlook Email before I send it out. Everything seems fine, the attachment is also there. But the only issue is that I can't display the Signature. Can anybody review this code and help me out please?

 

[DanteAmor]

Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Replace these lines:

  With objEmail
    .To = CStr(strEmail)
    .Subject = strMailSubject
    .Body = strMailBody & Signature
    .Attachments.Add strFolder & "\" & strAttachment
    .Display
  End With

For these:

    With objEmail
      .To = CStr(strEmail)
      .Subject = strMailSubject
      .Attachments.Add strFolder & "\" & strAttachment
      .Display
      .HtmlBody = strMailBody & .HtmlBody
    End With

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[erisciveja]

Hello Dante. Thank you very much for your help. The signature does show up and it works now. However, the email is displayed all together without any spacing making it very hard to read. Is there a way to add spacing?

 

[DanteAmor]

However, the email is displayed all together without any spacing making it very hard to read. Is there a way to add spacing?

You will understand that I have no idea how your email body is in your cell of the "Mail_Details" sheet. I can only guess how that information is.
Assuming you have something like this:

Update cell B2 with something like this, notice how I'm putting <br> where I want a newline:

I made some improvements to the code that I can't pass up, so try this code:

Sub sendCustEmails()
  Dim objOutlook As Object, objEmail As Object
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim intRow As Long
  Dim strAudit$, strPrefix$, strName$, strEmail$, strAttachment$, strSignature$
  Dim strMailSubject$, strMailBody$, strFolder$
  
  Set objOutlook = CreateObject("Outlook.Application")
  Set sh1 = ThisWorkbook.Sheets("Mail_Details")
  Set sh2 = ThisWorkbook.Sheets("Client_Data")
  
  strMailSubject = sh1.Range("A2").Text
  strMailBody = sh1.Range("B2").Text
  
  intRow = 2
  While sh2.Range("A" & intRow).Text <> ""
    Set objEmail = objOutlook.CreateItem(0)
    strAudit = sh2.Range("A" & intRow).Text
    strPrefix = sh2.Range("B" & intRow).Text
    strName = sh2.Range("C" & intRow).Text
    strEmail = sh2.Range("D" & intRow).Text
    strAttachment = sh2.Range("E" & intRow).Text
    strSignature = sh2.Range("F" & intRow).Text
    
    strMailBody = Replace(strMailBody, "<Prefix>", strPrefix)
    strMailBody = Replace(strMailBody, "<Name>", strName)
    strMailBody = Replace(strMailBody, "<Audit>", strAudit)
    strMailBody = Replace(strMailBody, "<Signature>", strSignature)
    
    With objEmail
      .To = CStr(strEmail)
      .Subject = strMailSubject
      .Attachments.Add strFolder & "\" & strAttachment
      .Display
      .HtmlBody = strMailBody & .HtmlBody
    End With
    
    intRow = intRow + 1
  Wend
  MsgBox "Done"
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------