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

I am trying to import data from several tables embedded in a several .msg files. I think the sample code below is pretty close, but when I get to this line:

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

Everything is jammed into one cell. I understand the (row, column) convention, but I don't know how to split out the 'MyItem.Body' into rows and columns. Is there some way to explode the MyItem.Body object and loop through that?

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

CodePudding user response：

Here's something a little more specific than copying the whole message content:

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

CodePudding user response：

This ended up working for me.

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

You need to set a reference to MS Forms 2.0 Object Library

If MS Forms 2.0 Object Library doesn't show up in your Available Reference, follow the steps below to get it installed.

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