如何循環使用具有特定主題行的所有 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