我们如何从多个 .msg 文件的主体导入多个表？

Question

我正在尝试从嵌入在多个 .msg 文件中的多个表中导入数据。我认为下面的示例代码非常接近，但是当我到达这一行时：

ws.Cells(i, 1) = MyItem.Body

所有东西都挤在一个牢房里。我了解 (row, column) 约定，但我不知道如何将 'MyItem.Body' 拆分为行和列。有什么方法可以分解 MyItem.Body 对象并循环遍历它吗？

Sub ImportMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim Msg As MailItem
Dim ws As Worksheet
Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem

Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("Sheet1")

'With Application.FileDialog(msoFileDialogFolderPicker)
'   .AllowMultiSelect = False
'        If .Show = False Then
'            Exit Sub
'        End If
'    On Error Resume Next
'    inPath = .SelectedItems(1) & "\"
'End With

inPath = "C:\Users\ryans\OneDrive\Desktop\test\"
thisFile = Dir(inPath & "*.msg")
i = 1
Do While thisFile <> ""
    Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
    ws.Cells(i, 1) = MyItem.Body
    i = i + 1
    thisFile = Dir()
Loop

Set MyItem = Nothing
Set myOlApp = Nothing

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Answer 1

这最终对我有用。

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:\Users\ryans\OneDrive\Desktop\test\tables.msg" ' change path & name of msg file
    Set Msg = x.OpenSharedItem(Path)

    With Sheets("Sheet1")
        ' requires Microsoft Forms 2 Object Library under Tools/References
        With New MSForms.DataObject
            .SetText Msg.HTMLBody
            .PutInClipboard
        End With
        .Range("A1").PasteSpecial (xlPasteAll) ' change paste type if necessary
    End With
End Sub

您需要设置对 MS Forms 2.0 对象库的引用

如果 MS Forms 2.0 对象库未显示在您的可用参考中，请按照以下步骤进行安装。

https://excel-macro.tutorialhorizon.com/vba-excel-reference-libraries-in-excel-workbook/

Answer 2

这里有比复制整个邮件内容更具体的内容：

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
    Dim tbl

    Set MyOutlook = New Outlook.Application
    Path = "C:\Tester\Tester2.msg"
    Set msg = MyOutlook.GetNamespace("MAPI").OpenSharedItem(Path)
    
    ExtractTable msg, 1, Sheet1.Range("C10")
    
    msg.Close olDiscard
End Sub

'Copy the content of a table (specified by index) to a location on a worksheet
'(note: will likely fail if the table has merged cells/columns)
Sub ExtractTable(msg As Outlook.MailItem, tNum As Long, rngTL As Range)
    Dim tbl, rNum As Long, cNum As Long, r As Long, c As Long, txt
    Set tbl = msg.GetInspector.WordEditor.tables(tNum)
    rNum = tbl.Rows.Count
    cNum = tbl.Columns.Count
    For r = 1 To rNum
        For c = 1 To cNum
            txt = tbl.cell(r, c).Range.Text
            txt = Left(txt, Len(txt) - 2) 'remove end-of-cell marker
            rngTL.Offset(r - 1, c - 1).Value = txt
        Next c
    Next r
End Sub

我们如何从多个 .msg 文件的主体导入多个表？

How can we import multiple tables from the body of a multiple .msg files?

excel

outlook

vba