VBA: 将单元格区域作为邮件正文发送到指定邮箱

Option Explicit

Sub 发送邮件()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("test") '将"test"替换为你要操作的工作表名称

    '设置邮件参数
    Dim outlookApp As Object
    Set outlookApp = CreateObject("Outlook.Application")
    
    Dim mailItem As Object
    Set mailItem = outlookApp.CreateItem(0)
    
    With mailItem
    
        .To = "xxx" '将"xxx"替换为实际的收件人邮箱地址
        
        .Subject = "测试数据的最新日期" '将"邮件主题"替换为实际的邮件主题
        
        .HTMLBody = "详情如下：" & RangetoHTML(ws.Range("A1:G4")) '使用HTML格式的正文
        
        .Send '发送邮件
        
    End With

    '释放对象
    Set mailItem = Nothing
    Set outlookApp = Nothing
    
End Sub


Function RangetoHTML(rng As Range) As String

    '将单元格区域转化为HTML格式

    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"
    
    Set TempWB = Workbooks.Add(1)
    
    ' 复制范围到临时工作簿
    rng.Copy
    
    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
    
    ' 保存临时工作簿为HTML文件
    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
    
    ' 读取HTML文件内容
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    
    ' 删除临时文件和工作簿
    fso.DeleteFile TempFile
    
    TempWB.Close savechanges:=False
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function