我們如何從多個.msg檔案的正文中匯入多個表？

我正在嘗試從嵌入在幾個 .msg 檔案中的幾個表中匯入資料。我認為下面的示例代碼非常接近，但是當我到達這一行時：

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

一切都擠在一個牢房里。我了解（行，列）約定，但我不知道如何將“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

uj5u.com熱心網友回復：

這里有一些比復制整個訊息內容更具體的內容：

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

uj5u.com熱心網友回復：

這最終為我作業。

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/

標籤：

上一篇：如何將多個VBA變數傳遞到呼叫的Powershell腳本中？

下一篇：根據特定單元格值清除Excel表格中的列內容