自动将HTML表格从Outlook导出到带有VBA的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的主题，我设法使用拆分(按行)复制了电子邮件的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\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打开，然后在运行宏时非常快速地关闭.但是，当我打开工作簿时，表应该是空白的表:(
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\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运行，因此在新规则中使用它很有用，因此根据定义的标准它将是自动的.我希望它对其他人有帮助！
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!
edit:为了在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.
这篇关于自动将HTML表格从Outlook导出到带有VBA的Excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
