Question

我正在尝试将特定文件夹的每个邮件的第一张表提取到Excel。如果邮件中有多个表格，我们可以将其排除并移至下一个邮件项目。以下是我目前拥有的代码。能否请你帮忙？

Public Sub Import_Tables_From_Outlook_Emails()
    Dim oApp As Outlook.Application, oMapi As Outlook.MAPIFolder
    Dim oMail As Outlook.MailItem, HTMLdoc As MSHTML.HTMLDocument
    Dim tables As MSHTML.IHTMLElementCollection, table As MSHTML.HTMLTable
    Dim objExcelApp As Excel.Application, x As Long, y As Long, destCell As Range
    Dim objExcelWorkbook As Excel.Workbook, objExcelWorksheet As Excel.Worksheet

    Set objExcelApp = CreateObject("Excel.Application") 'Create a new excel workbook
    Set objExcelWorkbook = objExcelApp.Workbooks.Add
    objExcelApp.Visible = True
    Set destCell = ActiveSheet.Cells(Rows.Count, "A").End(xlUp)

    On Error Resume Next
    Set oApp = GetObject(, "OUTLOOK.APPLICATION")
    If oApp Is Nothing Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
    On Error GoTo 0

    Set oMapi = oApp.GetNamespace("MAPI").PickFolder
    If Not oMapi Is Nothing Then
        For Each oMail In oMapi.items
             'Get HTML tables from email object
              Set HTMLdoc = New MSHTML.HTMLDocument 
            With HTMLdoc
                .Body.innerHTML = oMail.HTMLBody
                Set tables = .getElementsByTagName("table")
            End With
            For Each table In tables
                For x = 0 To table.Rows.Length - 1
                    For y = 0 To table.Rows(x).Cells.Length - 1
                        destCell.Offset(x, y).Value = _
                            table.Rows(x).Cells(y).innerText
                    Next y
                Next x
                Sheets.Add After:=ActiveSheet
                Range("A1").Activate
                Set destCell = ActiveSheet.Range("A1")
            Next
        Next
    End If
    Set oApp = Nothing
    Set oMapi = Nothing
    Set oMail = Nothing
    Set HTMLdoc = Nothing
    Set tables = Nothing
    MsgBox "Finished"
End Sub

Answer 1

以下宏提示用户从Outlook中选择一个文件夹，循环浏览该文件夹中的每个项目，并将每个项目中的第一个表复制到新创建的工作簿中的单独工作表中。

编辑 该代码已被编辑为：1）根据ReceivedTime限制邮件项目，2）按ReceivedTime排序受限制项目，并按降序排列3）从最早日期到最新日期循环浏览这些项目。

Option Explicit

Public Sub Import_Tables_From_Outlook_Emails()

    Dim oMapiFolder As Folder
    Dim oMail As Object
    Dim oMailItems As Object
    Dim oRestrictItems As Object
    Dim oHTMLDoc As Object
    Dim oHTMLTable As Object
    Dim xlApp As Object
    Dim xlWkb As Object
    Dim r As Long
    Dim c As Long
    Dim i As Long

    Set oMapiFolder = Application.GetNamespace("MAPI").PickFolder
    If oMapiFolder Is Nothing Then
        Exit Sub
    End If

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If xlApp Is Nothing Then
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
    End If
    On Error GoTo 0

    Set xlWkb = xlApp.workbooks.Add(-4167) 'xlWBATWorksheet

    Set oHTMLDoc = CreateObject("htmlfile")

    Set oMailItems = oMapiFolder.Items

    Set oRestrictItems = oMailItems.Restrict("[ReceivedTime] >= '" & Format("1/1/17 12:00am", "ddddd h:nn AMPM") & "'")

    oRestrictItems.Sort "[ReceivedTime]", olDescending

    For i = 1 To oRestrictItems.Count
        Set oMail = oRestrictItems(i)
        With oHTMLDoc
            .Body.innerHTML = oMail.HTMLBody
            Set oHTMLTable = .getElementsByTagName("table")(0)
        End With
        If Not oHTMLTable Is Nothing Then
            xlWkb.Worksheets.Add after:=xlWkb.activesheet
            For r = 0 To oHTMLTable.Rows.Length - 1
                For c = 0 To oHTMLTable.Rows(r).Cells.Length - 1
                    xlWkb.activesheet.Range("A1").Offset(r, c).Value = _
                        oHTMLTable.Rows(r).Cells(c).innerText
                Next c
            Next r
            Set oHTMLTable = Nothing
        End If
    Next i

    xlApp.DisplayAlerts = False
    xlWkb.Worksheets(1).Delete
    xlApp.DisplayAlerts = True

    Application.ActiveExplorer.Activate

    Set oMapiFolder = Nothing
    Set oMail = Nothing
    Set oHTMLDoc = Nothing
    Set oHTMLTable = Nothing
    Set xlApp = Nothing
    Set xlWkb = Nothing

    MsgBox "Finished"

End Sub

提取Outlook邮件文件夹的第一个表

1 个答案: