使用 VBA 自动将 HTML 表从 Outlook 导出到 Excel [英] Automatically export HTML Table from Outlook to Excel w/ VBA
问题描述
我想导出包含许多 HTML 格式表格的电子邮件.每个表都是这样的:
I'd like to export an email that contains many tables in HTML format. Each table is something like this:
<table class="MsoNormalTable" border="0" cellspacing="0" cellpadding="0" width="100%" style="width:100.0%;background:green">...</table>
我在 Outlook 中添加了一个新规则，因此每次我收到主题中包含特定单词"的电子邮件时，宏都会运行并将此电子邮件中的所有表格保存到 .xlsm 文件中.规则本身似乎工作正常，但我在使宏工作时遇到问题.
I've added a New Rule in Outlook, so everytime I receive an email with 'specific word' in the Subject, the macro runs and saves all the tables from this email to a .xlsm file. The rule itself seems to work fine, but i'm having issues to make the macro work.
我发现了许多关于将数据从 Outlook 导出到 Excel 的主题，并且我设法使用 split(按行)复制了电子邮件的 TextBody，但它仅适用于文本，而不适用于表格.
I've found many topics about exporting data from Outlook to Excel and I managed to copy email's TextBody using split (in rows), but it only worked with text, not with tables.
所以我开始在网上搜索有关导出表格的主题，我确实找到了一个.虽然，它谈到了使用 Excel VBA 从 Outlook 导入表格，但并不完全是我想要做的.我尝试编辑此代码以便在从 Outlook 运行时正常工作，但没有成功.
So I started searching the web for topics about exporting Tables, and I did find one. Although, it talks about importing Tables from Outlook using Excel VBA, not exactly what i'm trying to do. I tried to edit this code in order to work when running from Outlook, but it didn't work.
参考文献:
代码如下:
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
afael.kobayashiDesktopprojeto_licitacoesPalavras-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 打开然后关闭非常快.但是，当我打开工作簿时，表格应该是空白的工作表:(
There was a typo in the code, now it seems to be running, I can see that Excel opens then closes very quickly when I run the macro. However, when I open the workbook, the sheet where the tables were supposed to be is blank :(
我已经在一个邮件项目中测试了宏，我在其中插入了一个随机表并且它可以工作，但它不适用于我展示的邮件中的表.
I have tested the macro in an mail item where i inserted a random table and it worked, but it won't work with the tables in the mail that i showed.
我发现它不起作用，因为找到的第一个表在 innerText 中没有任何文本，所以我测试了一个获取所有表的宏并且它起作用了！
I've found out that it wasn't working because the first table found didn't have any text in innerText, so I tested a macro that gets all the tables and it worked!
推荐答案
我发现它不起作用，因为找到的第一个表在 innerText 中没有任何文本，所以我测试了一个可以获取所有表格的宏，并且可以正常工作！
I've found out that it wasn't working because the first table found didn't have any text in innerText, so I tested a macro that gets all the tables and it worked!
代码如下:
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
afael.kobayashiDesktopprojeto_licitacoesPalavras-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 运行，因此在新规则中使用很有用，因此它将根据定义的标准自动执行.我希望它可以帮助其他人！
It exports all the tables from the last received email in the Outlook Inbox to an Excel file. It skips 1 row between one table and the next. Since it gets the most recent email and it runs from Outlook, it's useful to use in a New Rule, so it will be automatic, according to a defined criteria. I hope it helps other people!
为了在 Outlook 规则中运行此宏，必须向 Sub 提供以下参数，否则宏将不会显示在要为规则选择的宏列表中:
edit: in order to run this macro in an Outlook Rule, it's necessary to give the following argument to the Sub, otherwise the macro won't be shown in the list of macros to be chosen for the Rule:
Public Sub SalvaExcel(item As Outlook.MailItem)
我已更新此答案中的代码.
I have updated the code in this answer.
这篇关于使用 VBA 自动将 HTML 表从 Outlook 导出到 Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
