问如何筛选主工作簿以表而不是文件的形式发送结果？

EN

Sub LoopThroughTable()

    Set ws = ActiveSheet

    For i = 2 To Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
        email_to = Sheet1.Cells(i, 5).Value
        email_subject = Sheet1.Cells(i, 4).Value

        folder_path = Sheet1.Cells(i, 2).Value

        Set FSO = CreateObject("Scripting.FileSystemObject")
        'Set fld = FSO.GetFolder(folder_path)
        If FSO.FolderExists(folder_path) Then
            'Nothing, folder is good
        Else
            'Just save to desktop
            folder_path = CreateObject("WScript.Shell").SpecialFolders("Desktop")
            Sheet1.Cells(i, 2).Value = folder_path
        End If

        If Right(folder_path, 1) <> "\" Then
            Sheet1.Cells(i, 2).Value = folder_path & "\"
        End If

        file_path = Sheet1.Cells(i, 2).Value & Sheet1.Cells(i, 3).Value

        sheet_name = Sheet1.Cells(i, 1).Value
        sheet_name_range = Sheet1.Cells(i, 9).Value
        Dim table_range As Range
        Dim range_string As String
        range_string = Sheet1.Cells(i, 10)
        Set table_range = Sheets(sheet_name_range).Range(range_string) 'Range("A3:C8") 'etc.

        email_body = Sheet1.Cells(i, 8).Value & "<br><br>" & ConvertRangeToHTMLTable(table_range)

        CopySheetAndSave sheet_name, file_path

        SendOutlookMessage email_to, email_subject, file_path, email_body
        ThisWorkbook.Activate
    Next i

    ws.Activate

End Sub

Sub CopySheetAndSave(ByVal sheet_name As String, ByVal full_path As String)

    SheetName = sheet_name
    FullPath = full_path

    Sheets(SheetName).Select
    Sheets(SheetName).Copy
    'ChDir "C:\Users\username\Downloads"
    Workbooks(Workbooks.Count).SaveAs Filename:=FullPath, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    Workbooks(Workbooks.Count).Close
End Sub


Sub SendOutlookMessage(ByVal email_to As String, ByVal email_subject As String, ByVal file_path As String, ByVal email_body As String)

    emailTo = email_to
    emailSub = email_subject
    FullPath = file_path
    HTMLBODY = email_body

    DoEvents
    Application.Wait 1

    Dim olApp As Object
    Dim olMail As Object

    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    With olMail
        .to = emailTo
        .Subject = emailSub
        .Attachments.Add (FullPath)

        .HTMLBODY = HTMLBODY
        DoEvents

        .Display
        Application.Wait 1
        .Send

    End With

    Application.Wait 1

    Set olMail = Nothing
    Set olApp = Nothing

End Sub

'Following function converts Excel range to HTML table
'Taken from https://excelsirji.com/vba-code-to-convert-excel-range-into-html-table/
Public Function ConvertRangeToHTMLTable(rInput As Range) As String
    'Declare variables
    Dim rRow As Range
    Dim rCell As Range
    Dim strReturn As String
    'Define table format and font
    strReturn = "<Table border='1' cellspacing='0' cellpadding='7' style='border-collapse:collapse;border:none'>  "
    'Loop through each row in the range
    For Each rRow In rInput.Rows
        'Start new html row
        strReturn = strReturn & " <tr align='Center'; style='height:10.00pt'> "
        For Each rCell In rRow.Cells
            'If it is row 1 then it is header row that need to be bold
            If rCell.Row = 1 Then
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'><b>" & rCell.Text & "</b></td>"
            Else
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'>" & rCell.Text & "</td>"
            End If
        Next rCell
        'End a row
        strReturn = strReturn & "</tr>"
    Next rRow
    'Close the font tag
    strReturn = strReturn & "</font></table>"
    'Return html format
    ConvertRangeToHTMLTable = strReturn
End Function