使用 VBA 自動將 HTML 表從 Outlook 導出到 Excel

Question

我想導出包含許多 HTML 格式表格的電子郵件。 每個表都是這樣的：

<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:100.0%;background:green">...</table>

我在 Outlook 中添加了一個新規則，因此每次我收到主題中包含“特定單詞”的電子郵件時，宏都會運行並將此電子郵件中的所有表格保存到 .xlsm 文件中。 規則本身似乎工作正常，但我在使宏工作時遇到問題。

我發現了很多關於將數據從 Outlook 導出到 Excel 的主題，並且我設法使用 split（按行）復制電子郵件的 TextBody，但它僅適用於文本，而不適用於表格。

所以我開始在網上搜索有關導出表格的主題，我確實找到了一個。 雖然，它談到了使用 Excel VBA 從 Outlook 導入表格，但並不完全是我想要做的。 我試圖編輯此代碼以便在從 Outlook 運行時正常工作，但它不起作用。

參考：

這是代碼：

Option Explicit
Public Sub SalvaExcel()

'This macro writes an Outlook email's body to an Excel workbook

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace

Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection

Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook


Dim FileName As String
'Dim TextBody As String
'Dim iArr() As String
Dim eRow As Integer
Dim xlUp As Integer
Dim i As Long
Dim j As Long
xlUp = -4162

'set email to be saved
Set olApp = Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
Set olMail = olItems(olItems.Count)

'save Outlook email's html body (tables)
With olHTML
    .Body.innerHTML = olMail.HtmlBody
    Set olEleColl = .getElementsByTagName("table")
End With



'set excel file to be opened
FileName = "C:\Users\rafael.kobayashi\Desktop\projeto_licitacoes\Palavras-Chave.xlsm"

'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")

'in this instance
With xlApp

    .Visible = True     'this slows down the macro, but helps during debugging
    .ScreenUpdating = False     'reduces flash and increases speed

    'open workbook
    Set ExcelWkBk = xlApp.Workbooks.Open(FileName)

    'in this workbook
    With ExcelWkBk

        'in [email] worksheet
        With .Worksheets("email")

            'find first empty row
            'eRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1

            'write table in excel
            Debug.Print olEleColl(0)
            For i = 0 To olEleColl(0).Rows.Length - 1 
                For j = 0 To olEleColl(0).Rows(i).Cells.Length - 1

                    .Range("A1").Offset(i, j).Value = olEleColl(0).Rows(i).Cells(j).innerText

                Next j
            Next i


            'resize columns (DO NOT)
            '.Columns("B:C").AutoFit

        End With

        'close Workbook and save changes
        .Close SaveChanges:=True

    End With

    'quit excel
    .Quit

End With

Set xlApp = Nothing
Set ExcelWkBk = Nothing
Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing


End Sub

編輯：代碼中有一個錯字，現在它似乎正在運行，我可以看到 Excel 在運行宏時打開然后很快關閉。 但是，當我打開工作簿時，表格應該是空白的工作表:(

EDIT2：我已經在一個郵件項目中測試了宏，我在其中插入了一個隨機表並且它可以工作，但它不適用於我展示的郵件中的表。

EDIT3：我發現它不起作用，因為找到的第一個表在innerText 中沒有任何文本，所以我測試了一個獲取所有表的宏並且它起作用了！

Answer 1

將該行更改為此

For i = 0 To olEleColl(0).Rows.Length - 1

（你拼錯了Length ）

Answer 2

我發現它不起作用，因為找到的第一個表在innerText 中沒有任何文本，所以我測試了一個獲取所有表的宏並且它起作用了！

這是代碼：

Public Sub SalvaExcel(item As Outlook.MailItem)

'This macro writes an Outlook email's tables to an Excel workbook

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace

Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection

Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook


Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String


'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")

'the most recent one
'Set olMail = olItems(olItems.Count)


'save Outlook email's html body (tables)
With olHTML
    .Body.innerHTML = item.HtmlBody
    Set olEleColl = .getElementsByTagName("table")
End With


'set excel file to be opened
FileName = "C:\Users\rafael.kobayashi\Desktop\projeto_licitacoes\Palavras-Chave.xlsm"

'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")

'in this instance
With xlApp

    .Visible = True     'if True, this slows down the macro, but helps during debugging
    .ScreenUpdating = False     'if False, this reduces flash and increases speed

    'open workbook
    Set ExcelWkBk = xlApp.Workbooks.Open(FileName)

    'in this workbook
    With ExcelWkBk

        'in [email] worksheet
        With .Worksheets("email")

            'which row to start
            eRow = 1
            posicao = "A" & eRow


            'write each table in excel
            For Each t In olEleColl

                For i = 0 To t.Rows.Length - 1
                    For j = 0 To t.Rows(i).Cells.Length - 1

                        'ignore any problems with merged cells etc
                        On Error Resume Next
                        .Range(posicao).Offset(i, j).Value = t.Rows(i).Cells(j).innerText
                        On Error GoTo 0

                    Next j
                Next i
                'define from which row the next table will be written
                eRow = eRow + t.Rows.Length + 1
                posicao = "A" & eRow
            Next t



        End With

        'close Workbook and save changes
        .Close SaveChanges:=True

    End With

    'quit excel
    .Quit

End With

Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing


End Sub

它將 Outlook 收件箱中最后收到的電子郵件中的所有表格導出到 Excel 文件。 它在一個表和下一個表之間跳過 1 行。 由於它獲取最新的電子郵件並從 Outlook 運行，因此在新規則中使用很有用，因此它將根據定義的標准自動執行。 我希望它可以幫助其他人！

編輯：為了在 Outlook 規則中運行此宏，必須向 Sub 提供以下參數，否則宏將不會顯示在要為規則選擇的宏列表中：

Public Sub SalvaExcel(item As Outlook.MailItem)

我已經更新了這個答案中的代碼。

Answer 3

感謝分享代碼。

已更正您的代碼以使其最終工作;)

Public Sub SalvaExcel()
'Public Sub SalvaExcel(item As Outlook.MailItem)
'This macro writes an Outlook email's tables to an Excel workbook

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olFoldersDefault As Outlook.Folders
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.Items
Dim olNameSpace As Outlook.NameSpace

Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim olEleColl As MSHTML.IHTMLElementCollection

Dim xlApp As Excel.Application
Dim ExcelWkBk As Excel.Workbook

Dim FileName As String
Dim eRow As Long
Dim i As Long
Dim j As Long
Dim t
Dim posicao As String


'set email to be saved
'Set olApp = Outlook.Application
'Set olNameSpace = Application.GetNamespace("MAPI")
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
'Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")

'Set olApp = Outlook.Application
Set olNameSpace = Application.GetNamespace("MAPI")
Set newFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olFolder = newFolder.Folders("Projects").Folders("Management").Folders("Notifications")

Set olItems = olFolder.Items
olItems.Sort ("[ReceivedTime]")

'the most recent one
Set olMail = olItems(olItems.Count)

'MsgBox olMail
'MsgBox olMail.HTMLBody

'save Outlook email's html body (tables)
With olHTML
    .Body.innerHTML = olMail.HTMLBody
    Set olEleColl = .getElementsByTagName("table")
End With


'set excel file to be opened
FileName = "D:\OutlookEmails.xlsm"

'create an Excel instance
Set xlApp = Application.CreateObject("Excel.Application")

'in this instance
With xlApp

    .Visible = True     'if True, this slows down the macro, but helps during debugging
    .ScreenUpdating = False     'if False, this reduces flash and increases speed

    'open workbook
    Set ExcelWkBk = xlApp.Workbooks.Open(FileName)

    'in this workbook
    With ExcelWkBk

        'in [email] worksheet
        With .Worksheets("emails")

            'which row to start
            eRow = 1
            posicao = "A" & eRow


            'write each table in excel
            For Each t In olEleColl

                For i = 0 To t.Rows.Length - 1
                    For j = 0 To t.Rows(i).Cells.Length - 1

                        'ignore any problems with merged cells etc
                        On Error Resume Next
                        .Range(posicao).Offset(i, j).Value = t.Rows(i).Cells(j).innerText
                        On Error GoTo 0

                    Next j
                Next i
                'define from which row the next table will be written
                eRow = eRow + t.Rows.Length + 1
                posicao = "A" & eRow
            Next t



        End With

        'close Workbook and save changes
        .Close SaveChanges:=True

    End With

    'quit excel
    .Quit

End With

Set xlApp = Nothing
Set ExcelWkBk = Nothing
'Set olMail = Nothing
Set olHTML = Nothing
Set olEleColl = Nothing


End Sub