Email worksheet (attached as PDF and embedded in email)

Hi,
I am trying to upload a page in a spreadsheet to an email.
I have multiple graphs at the top, followed by a filtered list at the bottom.
I want to add the whole thing (graphs and filtered list) as a PDF (currently getting graphs and filter headings, no list below).
I also want to add the Graphs as images and the list below embedded in the email (currently get 1 graph, and headings, no list).
Still new to this - sorry about the messy code !

Sub EmailProcess() '

Dim Fname As String                                 'Email with DMS Header
Dim SFname As String
Dim chart_number As Integer
Dim rng As Range                                    'Create Outlook Object
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim Cell As Range
Dim ws As Worksheet
Dim lrow As Long

    'Email ProcessT2 Update
'Set Header ratio to 100% for email
Sheets("T2-Process").Activate
ActiveWindow.Zoom = 100

Fname = ""
SFname = ""

    'File path/name of the jpg file
    Fname = Environ$("temp") & "\Process_Header.jpg"
    'Fname = "DMS_Header.jpg"
    SFname = "<img src='cid:Process_Header.jpg'width=width*1.4 height=heigth*1.4>"
    'Save Charts as jpg file
 
    ActiveSheet.ChartObjects("Chart 1").Chart.Export _
            Filename:=Fname, FilterName:="jpg"
        
Debug.Print Fname

'PDF/ Email

ThisWorkbook.Sheets(Array("T2-Process")).Select

lrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row
'Set rng = Sheets("T2-Process").Range("B1:BM" & lrow)
ActiveSheet.PageSetup.PrintArea = Range("B1:BM" & lrow).Address

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    "C:\Users\Public\Process.pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, _
     IgnorePrintAreas:=False, OpenAfterPublish:=False


lrow = Cells(Cells.Rows.Count, "B").End(xlUp).Row
Set rng = Sheets("T2-Process").Range("B20:BM" & lrow)
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
         .To = "xx <[email protected]>"
        .CC = "xx <[email protected]>"
        .Subject = "T2 DMS Comms"
        .Attachments.Add "C:\Users\Public\Process.pdf"
        .Attachments.Add Fname
        .HTMLBody = SFname & RangetoHTML(rng)
        If DisplayEmail = False Then
            '.Send
        End If
    End With

ThisWorkbook.Sheets("T2-Process").Select

End Sub

I have completely re-written the code and have the results I want.
Now copy the range of graphs and paste as image.
2 minor roadbumps that would be great if someone could help:
1) Image attaches fine, but has a white gap at the bottom (bottom of chart page). Cannot figure out how to crop this away
2) All cells format correctly when creating temp workbook, but when inserting into email the last 3 headings merge into one cell, and all the data below follows the same

Attachment 642666

Sub Email1()
Dim todaysDate As Date
Dim sh As Worksheet
Dim Fname As String                                 'Email with DMS Header
Dim SFname As String
Dim Lastrow As Integer
Dim rng As Range                                    'Create Outlook Object
Dim xOutlookObj As Object
Dim xEmailObj As Object


    'Email T3 Update
'Set Header ratio to 100% for email
Sheets("T3").Activate
ActiveWindow.Zoom = 100

Fname = ""
SFname = ""

    'File path/name of the jpg file
    Fname = Environ$("temp") & "\DMS_Header.jpg"
    'Fname = "DMS_Header.jpg"
    SFname = "<img src='cid:DMS_Header.jpg'width=width*1.4 height=heigth*1.4>"
    'Save Charts as jpg file
    
    Charts.Add.Name = "Chart1"
    ActiveChart.ChartArea.ClearContents
    Sheets("T3").Select
    Range("A1:CG18").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

   Sheets("Chart1").Select
   ActiveChart.Paste
   ActiveWindow.Zoom = 170
    ActiveChart.Export Filename:=Fname
Application.DisplayAlerts = False 'switching off the alert button
    ActiveChart.Delete
Application.DisplayAlerts = True 'switching on the alert button
Debug.Print Fname

'PDF/ Email

Lastrow = ActiveSheet.Cells(Rows.Count, 83).End(xlUp).Row
Set rng = Sheets("T3").Range("A19:CG" & Lastrow)
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
         .To = ""
        .CC = ""
        .Subject = "DMS T3 " & Date
        .Attachments.Add Fname
        .HTMLBody = SFname & RangetoHTML(rng)
'        If DisplayEmail = False Then
            '.Send
'        End If
    End With

End Sub



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