将内容从Word文档粘贴到Outlook邮件时保持格式

Question

我试图在Excel中运行宏以复制Word文档中的内容，将其粘贴到Outlook中，其格式与Word文档中的格式相同，然后发送到Excel单元格中的电子邮件地址。

我尝试了DataObj.GetText和Content.Paste，但都无法正常工作。

Sub send_email()

    Dim olApp As Object
    Dim olMailItm As Object
    Dim iCounter As Integer
    Dim Dest As Variant
    Dim SDest As String
    Dim doc As Object
    Dim wd As Object
    Dim editor As Object
    Dim strPaste  As Variant
    Dim DataObj As MSForms.DataObject

    Set DataObj = New MSForms.DataObject

    Set wd = CreateObject("Word.Application")
    Set doc = wd.documents.Open(Filename:="C:\Users\Username\Documents\toEmail.docx", ReadOnly:=False)
    doc.Content.Copy
    DataObj.GetFromClipboard
    strPaste = DataObj.GetText(1)
    If strPaste = False Then Exit Sub

    doc.Close
    Set wd = Nothing

    ' Subject
    strSubj = "Important Credentials"
    On Error GoTo dbg

    ' Create a new Outlook object
    Set olApp = CreateObject("Outlook.Application")
    For iCounter = 1 To WorksheetFunction.CountA(Columns(1))

    ' Create a new item (email) in Outlook
    Set olMailItm = olApp.CreateItem(0)
    strBody = ""
    useremail = Cells(iCounter, 1).Value
    FullUsername = Cells(iCounter, 2).Value
    statLvl = Cells(iCounter, 3).Value
    Status = Cells(iCounter, 5).Value
    pwdchange = Cells(iCounter, 4).Value

    'Make the body of an email
    strBody = "Dear " & FullUsername & vbCrLf
    strBody = strBody & "Your status of " & statLvl & " is in " & Status & " state" & vbCrLf
    strBody = strBody & "The date and time of the last password change is " & pwdchange & vbCrLf

    olMailItm.To = FullUsername
    olMailItm.Subject = strSubj
    olMailItm.BodyFormat = 1

    olMailItm.Body = strPaste
    olMailItm.Send
    Set olMailItm = Nothing
    Next iCounter
    Set olApp = Nothing
dbg:
    'Display errors, if any
    If Err.Description <> "" Then MsgBox Err.Description

End Sub

没有错误消息，粘贴时不会保留源格式。