VBA to send range as email body

[sagarshah]

Hello,
I am working with Ron de Bruin's code and require some assistance.

I have multiple worksheets. Each worksheet contains a range that automatically converts to pdf and sends email to the recipient based on a criteria. This works perfectly. (code posted below).
I now want to add another range (J2:S17) for (each of the worksheets that have an attached pdf) into the email body of the recipient in question.

So for example:
Sheet A1 will convert dynamic range to pdf and send email to test@test.com
Sheet B2 will convert dynamic range to pdf and send email to abc@123.com
Sheet C3 will not process as no email recipient defined.

I would like to add range as follows:
email to test@test.com - sheetA1 Range J2:S17 (together with the attachment)
abc@123.com - sheetb2 Range J2:S17 (together with the attachment)



Code to send email:

Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
                              StrCC As String, StrBCC As String, StrSubject As String, _
                              Signature As Boolean, Send As Boolean, StrBody As String)
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
  
    On Error Resume Next
      With OutMail
        If Signature = True Then .Display
        .To = StrTo
        .CC = StrCC
        .BCC = StrBCC
        .Subject = StrSubject
        .Attachments.Add FileNamePDF
                
        'need to edit this so it refers to the correct sheet
        Set rng = Nothing
        On Error Resume Next
        Set rng = ActiveSheet.Range("J2:S17").SpecialCells(xlCellTypeVisible)
        .HTMLBody = StrBody & RangetoHTML(rng)
        
        
        If Send = True Then
             .Send
        Else
            .Display
        End If
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Other Sub Routines used to create the pdf based on criteria and send it as email

Sub Mail_Every_Worksheet_With_Address_In_A1_PDF()
'Working only in 2007 and up
    Dim sh As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileName As String

    'Temporary path to save the PDF files
    'You can also use another folder like
    'TempFilePath = "C:\Users\Ron\MyFolder\"
    TempFilePath = Environ$("temp") & "\"

    'Loop through every worksheet
 
    For Each sh In ThisWorkbook.Worksheets

        FileName = ""

        'Test A1 for a mail address
        If sh.Range("b1").Value Like "?*@?*.?*" Then
                
    Call PrintArea1
                'If there is a mail address in A1 create the file name and the PDF
            TempFileName = TempFilePath & "Statement for " & sh.Name & ".pdf"

            FileName = RDB_Create_PDF(Source:=sh, _
                                      FixedFilePathName:=TempFileName, _
                                      OverwriteIfFileExist:=True, _
                                      OpenPDFAfterPublish:=False)

            'If publishing is OK create the mail
            If FileName <> "" Then
            
               Dim sMsgBody As String
 
sMsgBody = "<H3><B> Dear " & sh.Name & "</B></H3>"
sMsgBody = sMsgBody & "Please view the attached statement. Kindly remit payment at your earliest convenience " & "<br>" & "Thank you."


            
                RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
                                    StrTo:=sh.Range("B1").Value, _
                                     StrCC:="", _
                                     StrBCC:="", _
                                     StrSubject:="Statement for " & sh.Name, _
                                     Signature:=True, _
                                     Send:=False, _
                                     StrBody:=sMsgBody
                        

                                          
                                          
            Else
                MsgBox "Not possible to create the PDF, possible reasons:" & vbNewLine & _
                       "Microsoft Add-in is not installed" & vbNewLine & _
                       "You Canceled the GetSaveAsFilename dialog" & vbNewLine & _
                       "The path to Save the file in arg 2 is not correct" & vbNewLine & _
                       "You didn't want to overwrite the existing PDF if it exist"
            End If
          End If
    Next sh
End Sub

Function RDB_Create_PDF(Source As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the pdf
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            'If you cancel this dialog Exit the function
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False we test if the PDF
        'already exist in the folder and Exit the function if that is True
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now the file name is correct we Publish to PDF
        On Error Resume Next
        Source.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If Publish is Ok the function will return the file name
        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End Function

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .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
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

'Read all data from the htm file into RangetoHTML
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=")

'Close 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

 

[sagarshah]

The macro works however it only selects the range of the current worksheet and copies this same range on the email body across all the emails.
I would like to copy the range of the individual worksheet and paste it to the correct email body with the correct attachment

 

[sagarshah]

'amendment required here
Set rng = ActiveSheet.Range("J2:S17").SpecialCells(xlCellTypeVisible)

any assistance would be highly appreciated.