使用Excel VBA将.msg文件中的粘贴表数据复制到Excel工作表中的单独单元格中

Question

我有一个.msg文件，其中正文包含表格形式的数据。 我正在尝试将此数据复制到Excel并保留相同的表格形式。 此表格形式有2列和多行。

当我手动执行此操作时，我将在Excel中的不同单元格中获取每个值。

我有下面的代码。

Private Sub Workbook_Open()
    Dim MyOutlook As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim x As Namespace
    Dim Row As Integer
    Dim Path As String
    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")
    Path = "C:\Users\xxx\Downloads\Outlook Import\abc.msg"
    Set Msg = x.OpenSharedItem(Path)

    Sheets("Sheet2").Range("A1") = Msg.Sender
    Sheets("Sheet2").Range("A2") = Msg.CC
    Sheets("Sheet2").Range("A3") = Msg.To
    Sheets("Sheet2").Range("A4") = Msg.SentOn
    Sheets("Sheet2").Range("A5") = Msg.SenderEmailAddress
    Sheets("Sheet2").Range("A6") = Msg.ReceivedByEntryID
    Sheets("Sheet2").Range("A7") = Msg.Subject
    Sheets("Sheet2").Range("A8") = Msg.Body
End Sub

这是复制整个身体并将其粘贴到一个单元格中，即“ A8”。

Sheets("Sheet2").Range("A8") = Msg.Body

Answer 1

如果我正确理解了您的问题，您是否希望从Range("A8")开始在文档中逐行插入电子邮件正文？

这对我有用：

Private Sub Workbook_Open()
    Dim MyOutlook As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim x As Namespace
    Dim Row As Integer
    Dim Path As String
    Dim vItem As Variant

    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")
    Path = "C:\Test\test.msg" ' change path & name of msg file
    Set Msg = x.OpenSharedItem(Path)

    With Sheets("Sheet2")
        .Range("A1") = Msg.Sender
        .Range("A2") = Msg.CC
        .Range("A3") = Msg.To
        .Range("A4") = Msg.SentOn
        .Range("A5") = Msg.SenderEmailAddress
        .Range("A6") = Msg.ReceivedByEntryID
        .Range("A7") = Msg.Subject
        vItem = Split(Msg.Body, Chr(10))
        .Range("A8").Resize(UBound(vItem) - LBound(vItem) + 1, 1) = Application.Transpose(vItem)
    End With
End Sub

编辑＃1

这HTMLbody电子邮件HTMLbody复制到剪贴板，然后将其粘贴到文档中，然后保留列结构：

Private Sub Workbook_Open()
    Dim MyOutlook As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim x As Namespace
    Dim Row As Integer
    Dim Path As String
    Dim vItem As Variant

    Set MyOutlook = New Outlook.Application
    Set x = MyOutlook.GetNamespace("MAPI")
    Path = "C:\Test\test.msg" ' change path
    Set Msg = x.OpenSharedItem(Path)

    With Sheets("Sheet2")
        .Range("A1") = Msg.Sender
        .Range("A2") = Msg.CC
        .Range("A3") = Msg.To
        .Range("A4") = Msg.SentOn
        .Range("A5") = Msg.SenderEmailAddress
        .Range("A6") = Msg.ReceivedByEntryID
        .Range("A7") = Msg.Subject

        ' requires Microsoft Forms 2 Object Library under Tools/References
        With New MSForms.DataObject
            .SetText Msg.HTMLBody
            .PutInClipboard
        End With

        .Range("A8").PasteSpecial (xlPasteAll) ' change paste type if necessary

    End With

End Sub