Results 1 to 2 of 2

Thread: Modify the VBA code to exclude text only leave logo from signature

  1. #1
    Junior Member
    Join Date
    Nov 2017
    Posts
    21
    Rep Power
    0

    Modify the VBA code to exclude text only leave logo from signature

    Dear Friends,

    I have got this code below from this website which is a great piece of code form you gurus.

    I need help with modification of this code. I want to add to each email the logo which is in the Thisworkbook.worksheets("TEP").Shapes("Logo")

    I tried to modify the Range to html function to include objects but I failed.
    then i started using the signature removing all text from the htm signature and only leaving the logo., but i do not know how to do that.

    so either to change the range to html to include objects or if this is not possible then to change the blnSignature to remove anything text only leaving logo. either of these will work for me.

    any help is apprecited. thank you.


    Code:
    Function SendMessage(strTo As String, Optional strCC As String, _
            Optional strBCC As String, Optional strSubject As String, _
            Optional strMessage As String, Optional rngToCopy As Range, _
            Optional strAttachmentPath As String, _
            Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean, _
            Optional strSentOnBehalfOfName As String)
         
        Dim objOutlook As Object 'Outlook.Application
        Dim objOutlookMsg As Object 'Outlook.MailItem
        Dim objOutlookRecip As Object 'Outlook.Recipient
        Dim objOutlookAttach As Object 'Outlook.Attachment
        Dim lngLoop As Long
        Dim strSignature As String
         
        If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
            MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
            Exit Function
        End If
        
        'Create the Outlook session.
        On Error Resume Next
        Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
        Err.Clear: On Error GoTo -1: On Error GoTo 0
        If objOutlook Is Nothing Then
            Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
        End If
         
        'Create the message.
        Set objOutlookMsg = objOutlook.CreateItem(0)
    
    
        With objOutlookMsg
            
            'Add the To recipient(s) to the message.
            For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
                If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
                    Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
                    objOutlookRecip.Type = 1 'olTO
                End If
            Next lngLoop
             
            'Add the CC recipient(s) to the message.
            For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
                If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
                    Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
                    objOutlookRecip.Type = 2 'olCC
                End If
            Next lngLoop
             
            'Add the BCC recipient(s) to the message.
            For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
                If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
                    Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
                    objOutlookRecip.Type = 3 'olBCC
                End If
            Next lngLoop
    
            If strSentOnBehalfOfName <> "" Then
                .SentOnBehalfOfName = strSentOnBehalfOfName
            End If
             
            'Set the Subject, Body, and Importance of the message.
            If strSubject = "" Then
                strSubject = ""
            End If
            .Subject = strSubject
            If strMessage = "" Then
                strMessage = "" & vbCrLf & vbCrLf
            End If
            .Importance = 2 'High importance
            If Not strMessage = "" Then
                .Body = strMessage & vbCrLf & vbCrLf
            End If
            
            If Not rngToCopy Is Nothing Then
                .HTMLBody = .Body & RangetoHTML(rngToCopy)
            End If
             
            'Add attachments to the message.
            For lngLoop = LBound(Split(strAttachmentPath, "|")) To UBound(Split(strAttachmentPath, "|"))
            If Not strAttachmentPath = "" Then
                If Len(Dir(Trim(Split(strAttachmentPath, "|")(lngLoop)))) <> 0 Then
                    Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, "|")(lngLoop)))
                Else
                    MsgBox "Unable to find the specified attachment '" & Trim(Split(strAttachmentPath, "|")(lngLoop)) & "'. Sending mail anyway."
                End If
            End If
            Next lngLoop
            
            If blnSignature Then
                'Win XP
                strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
                strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
                If Dir(strSignature) = "" Then
                'Win 7
                    strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
                    strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
                End If
            End If
             
            If Dir(strSignature) <> "" Then
                strSignature = GetBoiler(strSignature)
            Else
                strSignature = ""
            End If
            
            'MsgBox .htmlbody
            .HTMLBody = .HTMLBody & strSignature
                
            'Resolve each Recipient's name.
            For Each objOutlookRecip In .Recipients
                objOutlookRecip.Resolve
            Next
             
            'Should we display the message before sending?
            If blnShowEmailBodyWithoutSending Then
                .Display
            Else
                .Send
            End If
        End With
         
        Set objOutlook = Nothing
        Set objOutlookMsg = Nothing
        Set objOutlookAttach = Nothing
        Set objOutlookRecip = Nothing
         
    End Function
    
    Function RangetoHTML(rng As Range)
    
        'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
        Dim strTempFile As String
        Dim wbkTemp As Workbook
    
        strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
     
        'Copy the range and create a workbook to receive the data.
        rng.Copy
        Set wbkTemp = Workbooks.Add(1)
        With wbkTemp.Sheets(1)
            With .Cells(1)
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues, , False, False
                .PasteSpecial xlPasteFormats, , False, False
                .Select
            End With
            Application.CutCopyMode = False
            On Error Resume Next
                .DrawingObjects.Visible = True
                .DrawingObjects.Delete
            Err.Clear: On Error GoTo 0
        End With
     
        'Publish the sheet to an .htm file.
        With wbkTemp.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=strTempFile, _
             Sheet:=wbkTemp.Sheets(1).Name, _
             Source:=wbkTemp.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
     
        'Read all data from the .htm file into the RangetoHTML subroutine.
        RangetoHTML = GetBoiler(strTempFile)
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
     
        'Close wbkTemp
        wbkTemp.Close SaveChanges:=False
     
        'Delete the htm file.
        Kill strTempFile
     
        Set wbkTemp = Nothing
        
    End Function
    
    Function GetBoiler(ByVal strFile As String) As String
    
        'May not be supported in MAC
        Dim objFSO As Object
        Dim objTextStream As Object
        On Error Resume Next
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
        GetBoiler = objTextStream.ReadAll
        objTextStream.Close
        
        Set objFSO = Nothing
        Set objTextStream = Nothing
        
    End Function

  2. #2
    Junior Member
    Join Date
    Nov 2017
    Posts
    21
    Rep Power
    0
    I found this code below in the internet, this one you can see that it can pick up range with its image, i tried using the technique below into the above code, but i failed. I appreciate your help.

    Code:
    Private Function RngToEmail(rng As Range, eTo As String, eSubject As String)
        Dim wbThis As Workbook, wbNew As Workbook
        Dim tempFileName As String, imgName As String, newPath As String
    
        '~~> Do not change "Myimg". This will be used to
        '~~> identify the images
        Dim imgPrefix As String: imgPrefix = "Myimg"
    
        '~~> This is the temp html file name.
        '~~> Do not change this as when you publish the
        '~~> html file, it will create a folder Temp_files
        '~~> to store the images
        Dim tmpFile As String: tmpFile = "Temp.Htm"
    
        Set wbThis = Workbooks(rng.Parent.Parent.Name)
        Set wbNew = Workbooks.Add
    
        '~~> Copy the relevant range to new workbook
        rng.Copy wbNew.Worksheets("Sheet1").Range("A1")
    
        newPath = wbThis.Path & "\"
        tempFileName = newPath & tmpFile
    
        '~~> Publish the image
        With wbNew.PublishObjects.Add(xlSourceRange, _
            tempFileName, "Sheet1", rng.Address, xlHtmlStatic, _
            imgPrefix, "")
            .Publish (True)
            .AutoRepublish = True
        End With
    
        '~~> Close the new file without saving
        wbNew.Close (False)
    
        '~~> Read the html file in a string in one go
        Dim MyData As String, strData() As String
        Dim i As Long
        Open tempFileName For Binary As #1
        MyData = Space$(LOF(1))
        Get #1, , MyData
        Close #1
        strData() = Split(MyData, vbCrLf)
    
        '~~> Loop through the file
        For i = LBound(strData) To UBound(strData)
            '~~> Here we will first get the image names
            If InStr(1, strData(i), "Myimg_", vbTextCompare) And InStr(1, strData(i), ".Png", vbTextCompare) Then
                '~~> Insert actual path to the images
                strData(i) = Replace(strData(i), "Temp_files/", newPath & "Temp_files\")
            End If
        Next i
    
        '~~> Rejoin to get the new html string
        MyData = Join(strData, vbCrLf)
    
        '~~> Create the Email
        Dim OutApp As Object, OutMail As Object
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
        With OutMail
            .To = eTo
            .Subject = eSubject
    
            '~~> Set the body
            .HTMLBody = MyData
    
            '~~> Show the email. Change it to `.Send` to send it
            .Display
        End With
    
        '~~> Delete the temp file name
        Kill tempFileName
    End Function
    Last edited by flora; 09-02-2019 at 09:20 PM.

Similar Threads

  1. Add Digital Signature To PDF Using VBA
    By in.vaibhav in forum Excel Help
    Replies: 5
    Last Post: 08-16-2024, 09:56 PM
  2. Replies: 3
    Last Post: 06-07-2017, 05:27 PM
  3. Need help to modify the VBA code
    By jeremiah_j2k in forum Excel Help
    Replies: 8
    Last Post: 10-23-2014, 01:44 PM
  4. Try to modify printer defaults from access-vba
    By relui in forum Access Help
    Replies: 0
    Last Post: 10-24-2013, 02:56 PM
  5. Council to modify code
    By PcMax in forum Excel Help
    Replies: 4
    Last Post: 02-05-2012, 11:03 PM

Posting Permissions

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