VBA 代码循环遍历 Outlook 中的每个文件夹和子文件夹

Question

我正在尝试获取以下代码来查看 Outlook 中收件箱下的所有文件夹和子文件夹以及来自电子邮件的源数据。

代码运行，但它只查看收件箱中的电子邮件和收件箱的第一个子文件夹级别。但是，它不会查看第一个子文件夹中的所有后续子文件夹级别。

这就是它的外观

收件箱 --> 子文件夹 1 --> 停止查找

我想让它看透

收件箱 --> 子文件夹 1 --> 子文件夹 2 --> 子文件夹“n”

例如，我的收件箱中有以下文件夹：

1. 收件箱 --> 加拿大 --> 安大略 --> 多伦多

或

1. 收件箱 --> 衣服 --> 便宜衣服 --> 沃尔玛

它只查看收件箱和第一级，因此加拿大或衣服，但不查看加拿大/衣服下的文件夹，例如安大略或廉价衣服。我想让它走得更远，看看 Toronto 和 Walmart，它们是安大略和廉价服装下的文件夹。

Answer 1

有一个额外的循环，您正在混淆父级和文件夹。这是有效的 Excel 代码，忽略了您的工作簿和工作表。

Option Explicit

Sub repopulate3()

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olparentfolder As Outlook.Folder
Dim olMail As Object

Dim eFolder As Object
Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet

Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long

'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
    Set olApp = CreateObject("Outlook.Application")
End If

Set olNs = olApp.GetNamespace("MAPI")
Set olparentfolder = olNs.GetDefaultFolder(olFolderInbox)

'wb.Sheets("vlookup").range("A2:C500").ClearContents

'i think you want column E here, not L?
'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row

ProcessFolder olparentfolder

ExitRoutine:

Set olparentfolder = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub


Private Sub ProcessFolder(ByVal oParent As Outlook.Folder)

Dim olFolder As Outlook.Folder
Dim olMail As Object

Dim i As Long
Dim wb As Workbook
Dim ws As Worksheet
Dim iCounter As Long
Dim lrow As Long
Dim lastrow As Long

'Set wb = ActiveWorkbook
'Set ws = wb.Worksheets("vlookup")

'lastrow = ThisWorkbook.Worksheets("vlookup").Cells(Rows.count, "E").End(xlUp).Row

For i = oParent.Items.Count To 1 Step -1

    Debug.Print oParent
    If TypeOf oParent.Items(i) Is MailItem Then
        Set olMail = oParent.Items(i)

        Debug.Print " " & olMail.Subject
        Debug.Print " " & olMail.ReceivedTime
        Debug.Print " " & olMail.SenderEmailAddress
        Debug.Print

        'For iCounter = 2 To lastrow
            'If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell
                'With ws
                '   lrow = .range("A" & .Rows.count).End(xlUp).Row
                '   .range("C" & lrow + 1).Value = olMail.body
                '   .range("B" & lrow + 1).Value = olMail.ReceivedTime
                '   .range("A" & lrow + 1).Value = olMail.SenderEmailAddress
                'End With
            'End If
        'Next iCounter

    End If

Next i

If (oParent.Folders.Count > 0) Then
    For Each olFolder In oParent.Folders
        ProcessFolder olFolder
    Next
End If

End Sub