如何循环使用具有特定主题行的所有 Outlook 电子邮件，而不仅仅是使用宏的一封电子邮件？

Question

我有一个代码，它只为那些主题行为“卷数据”的电子邮件提取电子邮件的正文。 假设我的收件箱文件夹中有 10 封电子邮件，其主题行为“卷数据”。 我想遍历所有电子邮件，找到主题行为“卷数据”的电子邮件，然后仅从这 10 封电子邮件中提取电子邮件正文。 现在我的代码在第一次找到提到的主题时停止，而不是遍历我的整个收件箱。 我在下面发布我的代码。 任何帮助将不胜感激。

Option Explicit


Sub impOutlookTable()

Dim wkb As Workbook
Set wkb = ThisWorkbook

Sheets("Sheet1").Cells.ClearContents

' point to the desired email
Const strMail As String = "emailaddress"

Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object

With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With

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").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)

For Each oItem In oMapi.Items
    If oItem.Subject = "Volume data" Then
    
            Exit For
    End If
Next oItem


If Not oItem Is Nothing Then

' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable


Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With


'import in Excel
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
Set destCell = destCell.Offset(x)
Next
End If


Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing


wkb.SaveAs "C:\Users\Desktop\New_email.xlsm"


End Sub

Answer 1

将所有“操作”代码放在循环内的If语句中，而不是放在它之后，然后删除Exit For 。

您还需要一个计数器或其他东西，这样您就不会只是为每次迭代保存同一个文件的顶部。

未经测试

Option Explicit

Sub impOutlookTable()
Dim iCounter As Integer
iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook

Sheets("Sheet1").Cells.ClearContents

' point to the desired email
Const strMail As String = "emailaddress"

Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object

With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With

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").Folders(strMail).Folders("inbox")
Set oMail = oMapi.Items(oMapi.Items.Count)

For Each oItem In oMapi.Items
    If oItem.Subject = "Volume data" Then

        ' get html table from email object
        Dim HTMLdoc As MSHTML.HTMLDocument
        Dim tables As MSHTML.IHTMLElementCollection
        Dim table As MSHTML.HTMLTable


        Set HTMLdoc = New MSHTML.HTMLDocument
        With HTMLdoc
            .Body.innerHTML = oItem.HTMLBody
            Set tables = .getElementsByTagName("table")
        End With


        'import in Excel
        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
            Set destCell = destCell.Offset(x)
        Next


        Set oApp = Nothing
        Set oMapi = Nothing
        Set oMail = Nothing
        Set HTMLdoc = Nothing
        Set tables = Nothing

        wkb.SaveAs "C:\Users\Desktop\New_email_" & iCounter & ".xlsm"
        iCounter = iCounter + 1
    
    End If
Next oItem

End Sub