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

Question

我有大约2000封电子邮件，这些电子邮件是以zip文件发送给我的。电子邮件具有以下结构：

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

所有邮件都有相同的主题。从屏幕截图中可以看出，每个邮件都有多个表。这些表的每个邮件都有不同的行数。我的任务是将2000封邮件中包含的所有这些多个表格转换为excel以形成图形和图表。你能帮我解决一下如何通过自动化来解决这个问题。我尝试了一些可用的解决方案，但没有发现任何可以将Outlook电子邮件中的表转移到Excel。我有这个任务的截止日期，任何提示帮助将非常感谢。提前谢谢！

Answer 1

这对我有用。

在您的VBA项目中添加对Microsoft HTML Object Library的引用（在VB编辑器中的工具＆gt;＆gt;参考下）

假设Outlook已经打开，您的邮件存储在路径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