如何将 Outlook 2010 电子邮件中的表格传输到 Excel 2010

Question

I have around 2000 emails which were sent to me in a zip file. The emails have the following structure:

http://social.msdn.microsoft.com/Forums/getfile/429285

All mails have the same Subject. As can be seen from the screenshot, each mail has multiple tables. These tables have varying number of rows with each mail. My task is to get all of these multiple tables contained in 2000 mails into excel to form graphs and charts. Can you please help me with how to go about this through automation. I tried a few solutions available but found nothing which could transfer tables within Outlook emails to Excel. I have a deadline for this task and any prompt help will be really appreciated. Thanks in advance!

Answer 1

This worked for me.

Add a reference to Microsoft HTML Object Library In your VBA project (under Tools >> References in the VB editor)

Assumes outlook is already open, and your mails are stored in the path MSG_PATH .

Sub Tester()

Const MSG_PATH As String = "C:\_Stuff\test\mails\"

Dim ol, m, t, r, c
Dim doc As New MSHTML.HTMLDocument
Dim rng As Range, rw As Object
Dim f

    Set ol = GetObject(, "outlook.application")

    Set rng = ActiveSheet.Range("B2")

    f = Dir(MSG_PATH & "*.msg")

    Do While Len(f) > 0

        Set m = ol.CreateItemFromTemplate(MSG_PATH & f)
        doc.body.innerHTML = m.htmlbody
        m.Close False

        For Each t In doc.getElementsByTagName("table")
            rng.Offset(0, -1).Value = f
            For r = 0 To t.Rows.Length - 1
                Set rw = t.Rows(r)
                For c = 0 To rw.Cells.Length - 1
                    'ignore any problems with merged cells etc
                    On Error Resume Next
                    rng.Offset(r, c).Value = rw.Cells(c).innerText
                    On Error GoTo 0
                Next c
            Next r
            Set rng = rng.Offset(t.Rows.Length + 5)
        Next t

        f = Dir()
    Loop

End Sub