Consulting

Results 1 to 2 of 2

Thread: Add default Outlook signature (HTML) to email

  1. #1
    VBAX Newbie
    Joined
    Dec 2020
    Posts
    1
    Location

    Add default Outlook signature (HTML) to email

    Hi, I'm trying to add the outlook default signature to the email that I'm trying to create and everything I try if does not work. Can someone take a look at my code and let me know what code I need to add to get this work?


    Private Sub CommandButton1_Click()
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xHTMLBody As String
    Dim xRg As Range
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the data range:", "KuTools for Excel", Selection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    With Application
    .Calculation = xlManual
    .ScreenUpdating = False
    .EnableEvents = False
    End With


    Set xOutApp = CreateObject("outlook.application")
    Set xOutMail = xOutApp.CreateItem(olMailItem)
    Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
    TempFilePath = Environ$("temp") & ""
    xHTMLBody = "<span LANG=EN>" _
    & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
    & "Hi Jo," _
    & "<br>" _
    & "<br>" _
    & "Below are the numbers for today. Let me know if you have any questions." _
    & "<br>" _
    & "<br>" _
    & "<img src='cidashboardFile.jpg'>" _
    & "<br>" _
    & "<br>Thanks,</font></span>"


    With xOutMail
    .Subject = "MONEY FOR " & Format(Date, "MM/DD/YYYY")
    .Htmlbody = xHTMLBody
    .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
    .To = ""
    .Cc = ""
    '.Bcc = ""
    .Display
    End With
    End Sub
    Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    Dim xShape As Shape
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
    .Activate
    For Each xShape In ActiveSheet.Shapes
    xShape.Line.Visible = msoFalse
    Next
    .Chart.Paste
    .Chart.Export Environ$("temp") & "" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count ).Delete
    Set xRgPic = Nothing
    End Sub

  2. #2
    If you use the Outlook Word Editor as follows to create the message the default signature is retained and you process the message body as if working in Word from VBA.
    You will need to add the code function to start Outlook as indicated

    Private Sub CommandButton1_Click()
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim olInsp As Object
    Dim wdDoc As Object
    Dim oRng As Object
    Dim xHTMLBody As String
    Dim xRg As Range
        On Error Resume Next
        Set xRg = Application.InputBox("Please select the data range:", "KuTools for Excel", Selection.Address, , , , , 8)
        If xRg Is Nothing Then Exit Sub
        With Application
            .Calculation = xlManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With
    
    
        Set xOutApp = OutlookApp() 'requires code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to start Outlook correctly
        
        Set xOutMail = xOutApp.CreateItem(0)
        With xOutMail
            Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
            TempFilePath = Environ$("temp") & "\"
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor    'access the message body for editing
            .To = ""
            .Cc = ""
            '.Bcc = ""
            .Subject = "MONEY FOR " & Format(Date, "MM/DD/YYYY")
            .Attachments.Add TempFilePath & "DashboardFile.jpg", 1
            .Display
            Set oRng = wdDoc.Range
            oRng.Collapse 1
            oRng.Text = "Hi Jo," & vbCr & vbCr & "Below are the numbers for today. Let me know if you have any questions." & vbCr & vbCr
            oRng.Collapse 0
            wdDoc.InlineShapes.AddPicture FileName:=TempFilePath & "DashboardFile.jpg", Range:=oRng
            oRng.End = oRng.End + 1
            oRng.Collapse 0
            oRng.Text = vbCr & vbCr & "Thanks," & vbCr
        End With
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •