How to open and edit existing email

[ThrottleWorks]

Please see below code, this is working for me apart from the sign.
I am trying to copy the sign picture created by Ron's working code and paste in e-mail body.
I am trying to edit below code for the same.

Sub OpenEmailWithRange()

    Call DefineWorksheets

    Dim olApp As Object

    Dim olNS As Object

    Dim olMail As Object

    Dim olReply As Object

    Dim strFilePath As String

    Dim strSignature As String

    Dim MyFileName As String

    Dim emailPath As String

    Dim FilePath As String

    Dim olInsp As Object

  

    'Set the file path for the email message

    strFilePath = Sheets("ABC").Range("D37").Value

  

    'Create Outlook application object

    Set olApp = CreateObject("Outlook.Application")

  

    'Create Namespace object

    Set olNS = olApp.GetNamespace("MAPI")

  

    'Open the email message

    Set olMail = olNS.OpenSharedItem(strFilePath)

  

    'Create a reply to all

    Set olReply = olMail.ReplyAll

  

    'Set the subject and To fields of the reply email to match the original email

    olReply.Subject = olMail.Subject

    olReply.To = olMail.To

  

    'Set the recipient, CC, and subject of the email

    olReply.To = Sht_Email.Range("B1").Value2

    olReply.Cc = Sht_Email.Range("B2").Value2

    Sht_Email.Range("B4").Value2 = olReply.Subject

    olReply.Subject = Replace(olReply.Subject, "FW:", "RE:", , , vbTextCompare) & " - " & Sht_TMPLT.Range("D4")

  

  

'''    MyFileName = "Dummy_" & Sht_Map.Range("I2").Value2 & ".xlsb"

'''    FilePath = ThisWorkbook.path & "\" & MyFileName

'''    ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=50, CreateBackup:=False

  

    'Add the saved workbook as an attachment to the email

    If olReply.Attachments.Count > 0 Then

        For i = olReply.Attachments.Count To 1 Step -1

            olReply.Attachments.Item(i).Delete

        Next i

    End If

'''    olReply.Attachments.Add FilePath

  

    SigString = Environ("appdata") & "\Microsoft\Signatures\Mysig.htm"

    If Dir(SigString) <> "" Then

        Signature = GetBoiler(SigString)

    Else

        Signature = ""

    End If

  

    'Add the email signature to the reply email

    strSignature = olApp.CreateItem(0).HTMLBody

    olReply.HTMLBody = "<span style='font-family: Calibri; font-size: 10pt;'>Dear Valued Client,<br><br>" & _

                       "ABC<br>" & _

                       "ABCD:</span><br><br>" & _

                       Replace(olReply.HTMLBody, "DEFG<br><br><br>", "") & Signature



  

    'Copy the Excel range

    Dim rng As Range

'''    Set rng = Sht_Email.Range("I1:K5")

  

    If Sht_TMPLT.Range("D2") = "Single" Then

        ' Copy a range from the TMPLT sheet and paste it as a bitmap into the email

        lastRow = Sht_Email.Range("$I65000").End(xlUp).Row

        Set rng = Sht_Email.Range("I1:N" & lastRow)

      

        Sht_Email.Columns("I:M").AutoFit

        Sht_Email.Columns("J:J").ColumnWidth = 35

        Sht_Email.Range("I1:N" & lastRow).Rows.AutoFit

        rng.Copy

    End If

  

    'Create a new Word document and paste the range

    Dim wdDoc As Object

    Dim wdRange As Object

  

    Set olInsp = olReply.GetInspector

  

    If Not olInsp Is Nothing Then

        Set wdDoc = olInsp.WordEditor

        Set wdRange = wdDoc.Range

      

        wdRange.Find.Execute "ABCDEF", , , , , , True

        wdRange.Collapse 0

        wdRange.InsertAfter "<br><br>"

        wdRange.Collapse 0

        If Sht_TMPLT.Range("D2") = "Single" Then

            wdRange.PasteExcelTable False, False, False

        End If

'''        wdRange.InsertAfter "<br><br>"

    End If

  

    ' Remove unwanted HTML tags from the email

    wdRange.Find.Execute FindText:="<o:p></o:p>", ReplaceWith:="", Replace:=2

    wdRange.Find.Execute FindText:="<p>&nbsp;</p>", ReplaceWith:="", Replace:=2

    wdRange.Find.Execute FindText:="<p>", ReplaceWith:="", Replace:=2

    wdRange.Find.Execute FindText:="<br><br>", ReplaceWith:="", Replace:=2

  

    ' Replace any remaining "<br>" tags with line breaks

    wdRange.Find.Execute FindText:="<br>", ReplaceWith:=vbCr, Replace:=2



    'Display the reply email

    olReply.Display

  

    'Clean up objects

    Set olReply = Nothing

    Set olMail = Nothing

    Set olNS = Nothing

    Set olApp = Nothing

End Sub

 

[Debaser]

Do you have images in your signature? If not, then that code should work, as long as the path to the signature is correct.

 

[ThrottleWorks]

Hi @Debaser , thanks for the help. There is one image in e-mail signature.
Have a nice day ahead.

 

[ThrottleWorks]

Hi @Debaser , you may consider this issue as solved. Thanks a lot for you help.

 

[Debaser]

Might be useful for others if you post your solution?

 

[ThrottleWorks]

Hi @Debaser , actually this part was taking more time than the entire solution hence I dropped the idea for time being.
I have exact e-mail signature copied from Outlook to Excel as picture with another code, not able to post that picture in my existing e-mail editing sub. Will re-try once I get some time from the entire solution.

Have a nice day ahead.