如何从 Outlook 中的文件夹、子文件夹、子文件夹中获取主题？

Question

我已构建以从 Outlook 收件箱中获取主题。它将从收件箱和收件箱文件夹中提取主题。没有硬编码的文件夹下子文件夹少，怎么解压？

从 Inbox、FolderA、FolderB、FolderC 等读取主题的预期结果。FolderA 下可能有几个子文件夹。

当前 Excel VBA 代码：

Option Explicit
Sub GetMailInfo()

Dim results As Variant

' get contacts
results = ExportEmails(True)

' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results

' done
MsgBox "Completed"

End Sub
Function ExportEmails(Optional headerRow As Boolean = False) As Variant

Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As ResultItem
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer
Dim resultsList As New Collection

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A5").Select

Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
GetFolderMails strFolderName, resultsList

' if calling procedure wants header row
If headerRow Then
  startRow = 1
Else
  startRow = 0
End If

numRows = resultsList.Count

' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)

' loop through folder items
For i = 1 To numRows
    Set folderItem = resultsList.Item(i)

    With folderItem
        tempString(i + startRow, 1) = .CreationTime
        tempString(i + startRow, 2) = .SenderName
        tempString(i + startRow, 3) = .ReceivedByName
        tempString(i + startRow, 4) = .ReceivedTime
        tempString(i + startRow, 5) = .ToName
        tempString(i + startRow, 6) = .Subject
        If .Attachments.Count > 0 Then
            For jAttach = 1 To .Attachments.Count
                tempString(i + startRow, 39 + jAttach) = .Attachments.Item(jAttach)
            Next jAttach
        End If
    End With
Next i

' first row of array should be header values
If headerRow Then
    tempString(1, 1) = "CreationTime"
    tempString(1, 2) = "SenderName"
    tempString(1, 3) = "ReceivedByName"
    tempString(1, 4) = "ReceivedTime"
    tempString(1, 5) = "To"
    tempString(1, 6) = "Subject"
End If

ExportEmails = tempString

' apply pane freeze and filtering
Range("A6").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
'Selection.AutoFilter

End Function
Function IsMail(itm As Object) As Boolean

IsMail = (TypeName(itm) = "MailItem")

End Function
Sub GetFolderMails(MailFolder As Object, resultsList As Collection)

Dim itm As Object
Dim newResult As ResultItem
Dim jAttach As Long
Dim subFolder As Object

For Each itm In MailFolder.Items
    If IsMail(itm) Then
        Set newResult = New ResultItem
        With itm
            newResult.CreationTime = .CreationTime
            newResult.SenderName = .SenderName
            newResult.ReceivedByName = .ReceivedByName
            newResult.ReceivedTime = .ReceivedTime
            newResult.ToName = .To
            newResult.Subject = .Subject
            If .Attachments.Count > 0 Then
                For jAttach = 1 To .Attachments.Count
                    newResult.Attachments.Add .Attachments.Item(jAttach).DisplayName
                Next jAttach
            End If
        End With
        resultsList.Add newResult
    End If
Next itm

For Each subFolder In MailFolder.Folders
    GetFolderMails subFolder, resultsList
Next subFolder

End Sub

Answer 1

感谢@TimWilliams

我已经修改了我的代码，以便在最后一部分进行捕获。

If (MailFolder.Items.Count > 0) Then
  For Each subFolder In MailFolder.Folders
    GetFolderMails subFolder, resultsList
Next subFolder
End If

现在工作正常。