Question

我想导出包含HTML格式的许多表格的电子邮件。每个表都是这样的：

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

我在Outlook中添加了新规则，因此每次收到包含＆＃39;特定字词的电子邮件时，在主题中，宏运行并将此电子邮件中的所有表保存到.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 中的任何文字，所以我测试了一个获取所有表格的宏并且它有效！“ / p>

以下是代码：

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文件。它在一个表和下一个表之间跳过一行。由于它获取最新的电子邮件并且它从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

自动将HTML表格从Outlook导出到带有VBA的Excel

3 个答案: