How to Send a Range from an Active Sheet in an Outlook Email Body from Active Workbook with VBA

VBA Macro to Send a Range from an Active Sheet in an Outlook Email Body from Active Workbook
Sub Mail_Selection_Range_Outlook_Body()
    Dim Rng As Range
    Dim OutlookApp As Object
    Dim NewMail As Object

    Set Rng = Nothing
    On Error Resume Next

    Set Rng = ActiveSheet.Range("MyRng")
'--You can also use a Fixed range if you want
    'Set Rng = Sheets("YourSheet").Range("A1:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The Selection is not a Range or the Sheet is Protected" & _
               vbNewLine & "Please Correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutlookApp = CreateObject("Outlook.Application")
    Set NewMail = OutlookApp.CreateItem(olMailItem)
    'Set NewMail = OutlookApp.CreateItem(0)
    
 '--Inserting Signature in Email Body
 '--Change only 'YourSignature.htm' to the name of your Signature
    SigString = Environ("appdata") & "\Microsoft\Signatures\Tamatam.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

 '--Selecting your desired Email Account for Sending From
 '--If the account is not in your profile, Then you need to use SentOnBehalfOfName
        For I = 1 To OutlookApp.Session.Accounts.Count
            If OutlookApp.Session.Accounts.Item(I) = "MyEmailAccountAlias@Domain.Com" Then
             MsgBox OutlookApp.Session.Accounts.Item(I) & " : This is account number " & I
                Acn_No = I
                Exit For
            End If
        Next I

'--Defining the Email Body Message
        Strbody = "<H3><B>TEST MAIL via EXCEL MACRO</B></H3>" & _
                    "This is sample test mail by Macro<br>" & _
                    "Please donot repond to it<br>" & _
                    "<A href=""https://excelkingdom.blogspot.in/"">Excel Kingdom</A>"
              
    On Error Resume Next

'--Opening a New Email to Send
    With NewMail
        .TO= "YourEmail@Domain.com" '--Your Email Id here
        .CC = ""
        .BCC = ""
        .Subject = "Test Message" '--Your Email Subject here
       '.Body = "This Your Email Boday ; '--You can use below one as well
        .HTMLBody = Strbody & "<br>" & "<br>" & _
                    RangetoHTML(Rng) & "<br>" & "<br>" & _
                    "<B>Thank you</B>" & "<br>" & "<br>" & Signature
        .SentOnBehalfOfName = OutlookApp.Session.Accounts.Item(Acn_No) 
        '--You can use below one as well
        '.SentOnBehalfOfName = "MyEmailAccountAlias@Domain.Com"
        '.SendUsingAccount = OutlookApp.Session.Accounts.Item(Acn_No)
        .Display '--Use .Display to show you the Email before sending it.
        .Send
    End With
    
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

-- This is will call to above Procedure to Copy the Range from Active sheet to a .htm file then to the Email Message Body

Function RangetoHTML(Rng As Range)
    Dim FSO As Object
    Dim TS As Object
    Dim TempFile As String
    Dim TempWB As Workbook

'--Creating a Temporary .htm file to Copy the Range from Active sheet.
    'TempFile = Environ$("temp") & "\" & Format(Now, "dd-mmm-yyyy") & ".htm"
     TempFile = Environ("UserProfile") & "\Desktop\Test\" & Format(Now, "dd-mmm-yyyy") 
                                                                                                 & ".htm"

 '--Copy the range and Paste the data to newly created Workbook
    'Rng.Select
    Rng.Copy
    Set TempWB = Workbooks.Add(xlWBATWorksheet)

'--Copy Pasting the Range from  Active Sheet to a Temp Workbook Sheet
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 'Paste with same Column Widths
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

'--Publish the Sheet to a htm file from Temp Workbook Sheet
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

 '--Reading all data from the htm file into RangetoHTML variable
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TS = FSO.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = TS.readall
    TS.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

'--Closing the TempWB
    TempWB.Close SaveChanges:=False

'--Delete the htm file we used in this Function
    Kill TempFile

    Set TS = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
End Function

-- This is will call to above Procedure to Copy the Signature to the Email Message Body
Function GetBoiler(ByVal SigFile As String) As String
    Dim FSO As Object
    Dim TS As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TS = FSO.GetFile(SigFile).OpenAsTextStream(1, -2)
    GetBoiler = TS.readall
    TS.Close

End Function

--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------