将一系列单元格作为富文本电子邮件（outlook）发送，并使用 Excel VBA 作为附件添加

Answer 1

您可以使用 Word 对象模型从 Excel 中复制所需的数据并将其粘贴到 Word 文档表示的消息正文中。

要将签名添加到消息正文中，您需要在对消息正文进行任何修改之前调用Display 方法。

请注意，在 Outlook 中处理邮件正文的主要方式有以下三种：

1. Body。
2. HTMLBody。
3. Word 编辑器。 Inspector 类的 WordEditor 属性返回代表消息正文的 Word 文档实例。

   请参阅Chapter 17: Working with Item Bodies 了解更多信息。

Answer 2

在某些情况下，对于几乎静态的电子邮件，您可以使用预先生成的 RTF 邮件正文。您可以在 RTF 中使用一些占位符并在电子邮件生成期间替换它们。这是带有表格的静态电子邮件的示例代码（没有文件附件）

Sub CreateRtfMail()
    
    Dim outlookApp As New Outlook.Application
    Dim eMail As Outlook.MailItem
    Set eMail = outlookApp.CreateItem(olMailItem)
    
    eMail.BodyFormat = olFormatRichText

    eMail.Body = _
        "{\rtf1\ansi\ansicpg1250\deff0\nouicompat\deflang1029\deflangfe1029{\fonttbl{\f0\fnil\fcharset238 Calibri;}{\f1\fnil Calibri;}{\f2\fnil\fcharset0 Calibri;}}" & vbCrLf & _
        "{\colortbl ;\red0\green0\blue0;}" & vbCrLf & _
        "{\*\generator Riched20 10.0.19041}{\*\mmathPr\mdispDef1\mwrapIndent1440 }\viewkind4\uc1 " & vbCrLf & _
        "\pard\sa200\sl240\slmult1\f0\fs22 Greetings\par" & vbCrLf & _
        "Body of message\par" & vbCrLf & _
        "\trowd\trgaph30\trleft-30\trrh290\trpaddl30\trpaddr30\trpaddfl3\trpaddfr3" & vbCrLf & _
        "\cellx1002\cellx2034 " & vbCrLf & _
        "\pard\intbl\cf1\f1 Adam1\cell Bob1\cell\row\trowd\trgaph30\trleft-30\trrh290\trpaddl30\trpaddr30\trpaddfl3\trpaddfr3" & vbCrLf & _
        "\cellx1002\cellx2034 " & vbCrLf & _
        "\pard\intbl Adam2\cell Bob2\cell\row " & vbCrLf & _
        "\pard\sa200\sl276\slmult1\cf0\f0\par" & vbCrLf & _
        "Sign\f2\lang5\par" & vbCrLf & _
        "}" & vbCrLf
    
    eMail.Display
    
End Sub

我使用写字板创建 RTF 文件而不是 MS Word 有最好的体验

Answer 3

在此代码中，附件出现在签名之后。与早期版本一样，将签名分配给文本变量可以更轻松地适当放置附件。

Option Explicit

Sub SendEmail_SignatureUnchanged_Expanded()

    Application.Calculation = xlCalculationManual
    
    ' Application is Excel. No influence in Outlook.
    Application.ScreenUpdating = False
    
    ' Reference Microsoft Outlook nn.n Object Library
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    
    ' Reference Microsoft Word nn.n Object Library
    Dim wdDoc As Word.Document
    Dim strGreeting As String
    Dim strSignature As String
    
    Dim objSelection As Excel.Range
    
    Set objSelection = Selection
    objSelection.Copy
    
    Dim objTempWorkbook As Excel.Workbook
    Set objTempWorkbook = Excel.Application.Workbooks.Add(1)
    
    Dim objTempWorksheet As Excel.Worksheet
    Set objTempWorksheet = objTempWorkbook.Sheets(1)
 
    Dim strTempHTMLFile As String, Strbody As String
    Dim objTempHTMLFile As Object, objTextStream As Object
 
    Dim objFileSystem As Object
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    
    ' Pasting into a Temp Worksheet
    With objTempWorksheet.Cells(1)
        .PasteSpecial xlPasteColumnWidths
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With
 
        ' Save the Temp Worksheet as a HTML File
    strTempHTMLFile = objFileSystem.GetSpecialFolder(2).Path & _
      "\Temp for Excel" & Format(Now, "YYYY-MM-DD hh-mm-ss") & ".htm"
    Set objTempHTMLFile = objTempWorkbook.PublishObjects.Add(xlSourceRange, _
      strTempHTMLFile, objTempWorksheet.Name, objTempWorksheet.UsedRange.Address)
    objTempHTMLFile.Publish (True)
    
    strGreeting = "Dear Someone," & vbNewLine
    
    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
        
        .BodyFormat = olFormatRichText
        Set olInsp = .GetInspector  ' A side effect is to get the signature
        
        Set wdDoc = olInsp.WordEditor
        
        wdDoc.Range.InsertBefore vbNewLine & vbNewLine
        
        wdDoc.Paragraphs(2).Range.Paste
        
        ' Alternative if you can figure out how to place it where you want
        '  wdDoc.Application.Selection.PasteAndFormat wdFormatOriginalFormatting
        
        ' Required otherwise the attachment did not appear
        .Display
        
        ' Insert the Temp Worksheet into the Email Body
        Dim wb1 As Workbook
        Set wb1 = ActiveWorkbook
        
        Dim TempFilePath As String
        TempFilePath = Environ$("temp") & "\"
        
        Dim TempFileName As String
        TempFileName = "Output Data"
        
        Dim FileExtStr As String
        FileExtStr = ".xlsx"
        
        Debug.Print TempFilePath & TempFileName
        wb1.SaveAs TempFilePath & TempFileName, FileFormat:=xlOpenXMLWorkbook
        
        ' Placed at end of email
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        ' You could try "Position" to place the attachment within the body.
        '  This parameter applies only to email messages using the Rich Text format.
        '  Possibly based on length of signature.
        '  https://docs.microsoft.com/en-us/office/vba/api/outlook.attachments.add
        '
        ' There could be Word VBA to manipulate the attachment.
        '  Possibly involving  wdDoc.Bookmarks("_MailAutoSig")
        '  https://stackoverflow.com/questions/70114895
        
        wdDoc.Range.InsertBefore strGreeting
        
    End With
    
    objTempWorkbook.Close (False)
    objFileSystem.DeleteFile (strTempHTMLFile)
    Kill TempFilePath & TempFileName & FileExtStr 'Delete the temp Excel File
    
    Set olApp = Nothing
    Set olEmail = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

---

How to paste multiple table ranges into Outlook body using Word Editor (As Images) 展示了如何使用 WordEditor。

Sub SendEmail_NoFormattingSig()

    ' Reference Microsoft Outlook nn.n Object Library
    Dim olApp As Outlook.Application
    Dim olEmail As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    
    ' Reference Microsoft Word nn.n Object Library
    Dim wdDoc As Word.Document
    Dim strGreeting As String
    Dim strSignature As String
    
    Dim objSelection As Excel.Range
    
    Set objSelection = Selection
    objSelection.Copy
        
    strGreeting = "Dear Someone," & vbNewLine
    
    Set olApp = New Outlook.Application
    Set olEmail = olApp.CreateItem(olMailItem)

    With olEmail
    
        .BodyFormat = olFormatRichText
        .Display
        
        ' Formatting lost if there is a default signature
        strSignature = .Body
        .Body = ""
        
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        
        wdDoc.Range.InsertBefore vbNewLine & vbNewLine
        
        wdDoc.Paragraphs(2).Range.Paste
        
        'Alternative if you can figure out how to position where you want
        ' wdDoc.Application.Selection.PasteAndFormat wdFormatOriginalFormatting

        wdDoc.Range.InsertAfter vbNewLine
        
        Debug.Print ActiveWorkbook.FullName
        .Attachments.Add (ActiveWorkbook.FullName)
        
        wdDoc.Range.InsertBefore strGreeting
        
        wdDoc.Range.InsertAfter strSignature
        
    End With
    
    Set olApp = Nothing
    Set olEmail = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing

End Sub

Answer 4

将活动选择作为表格发送。希望能帮助到你！

Sub ExtReqForm_SendEmail()
'Update 20131209
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
'SET RANGE HERE OR USE INPUT BOX TO SELECT
Set WorkRng = Sheets("SHEET NAME").Range("A1:A2").SpecialCells(xlCellTypeVisible)
Application.ScreenUpdating = False
WorkRng.Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
    .Introduction = ""
    .Item.To = ""
    .Item.CC = ""
    .Item.Subject = ""
    .Item.Send
End With
Application.ScreenUpdating = True
End Sub
'''