如何回圈使用具有特定主題行的所有Outlook電子郵件，而不僅僅是使用宏的一封電子郵件？

我有一個代碼，它只為那些主題行為“卷資料”的電子郵件提取電子郵件的正文。假設我的收件箱檔案夾中有 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

uj5u.com熱心網友回復：

將所有“操作”代碼放在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

標籤：擅长 vba

上一篇：我如何使用同一張表中的類似潛艇？

下一篇：使用Match或任何搜索功能獲取型別不匹配