将Outlook 2013搜索文件夹电子邮件导出到Excel

Question

I would like to export my emails in the Search Folders to Excel .

I am using the code below to export my email in the Inbox.

But with Search Folders it gives me an error :

Run-time error '-2147221233 (8004010f)

The attempted operation failed. An object could not be found.

Sub Download_Outlook_Mail_To_Excel()

Dim folders As Outlook.folders
Dim folder As Outlook.MAPIFolder
Dim iRow As Integer
Dim Pst_Folder_Name
Dim MailboxName

MailboxName = "xxx@yy.com"
Pst_Folder_Name = "Inbox"

Set folder = Outlook.Session.folders(MailboxName).folders(Pst_Folder_Name)

Sheets(1).Activate

For iRow = 1 To folder.Items.Count
    Sheets(1).Cells(iRow, 1).Select
    Sheets(1).Cells(iRow, 1) = folder.Items.Item(iRow).SenderName
    Sheets(1).Cells(iRow, 2) = folder.Items.Item(iRow).Subject
    Sheets(1).Cells(iRow, 3) = folder.Items.Item(iRow).ReceivedTime
    Sheets(1).Cells(iRow, 4) = folder.Items.Item(iRow).Categories
Next iRow

MsgBox "Outlook Mails Extracted to Excel"

End Sub

Answer 1

I finally found the solution. It only works with one specified Search Folders, named in the variable: Pst_Folder_Name. If you have more search folders you have to use a cycle somehow.

Sub Outlook_Emails_Handled_Last_Week()
    Dim colStores As Outlook.Stores
    Dim oStore As Outlook.Store
    Dim oSearchFolders As Outlook.folders
    Dim oFolder As Outlook.folder
    Dim mail As Outlook.MailItem
    Dim iRow As Integer
    Dim Pst_Folder_Name
    Dim MailboxName
    Dim Ws As Excel.Worksheet
    Dim LastRow As Integer

    MailboxName = "xxxx@yyy.com"
    Pst_Folder_Name = "Emails Handled Last Week"

    Set oFolder = Session.Stores.Item(MailboxName).GetSearchFolders(Pst_Folder_Name)

    Set Ws = ThisWorkbook.Worksheets("Sheet1")
    Ws.Activate

    LastRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row

        Ws.Cells(1, 1).Value = "Sender Name"
        Ws.Cells(1, 2).Value = "Subject"
        Ws.Cells(1, 3).Value = "Received Time"
        Ws.Cells(1, 4).Value = "Categories"

    For iRow = 1 To oFolder.Items.Count
        Ws.Cells(LastRow + iRow, 1) = oFolder.Items.Item(iRow).SenderName
        Ws.Cells(LastRow + iRow, 2) = oFolder.Items.Item(iRow).Subject
        Ws.Cells(LastRow + iRow, 3) = oFolder.Items.Item(iRow).ReceivedTime
        Ws.Cells(LastRow + iRow, 4) = oFolder.Items.Item(iRow).Categories

    Next iRow

    MsgBox "Completed!"

    End Sub

Answer 2

As Search folders can be preassigned or custom, the best way to detect them is to check the folder's .Class , which should be olSearch .

So this should work (I added a new Integer to keep writing if there is more than one Search folder) :

Sub Download_Outlook_Mail_To_Excel()

Dim folder As Outlook.MAPIFolder
Dim iRow As Integer
Dim LastWrow As Integer
Dim MailboxName As String
Dim Ws As Excel.Worksheet

MailboxName = "xxyy@zzz.com"
Set Ws = sheets(1)

For Each folder In Outlook.Session.folders(MailboxName).folders
    With folder
        If .Class <> olSearch Then
        Else
            Ws.Activate
            LastWrow = Ws.Range("A" & Ws.rows.Count).End(xlup).Row
            For iRow = 1 To .Items.Count
                'ws.Cells(iRow, 1).Select
                Ws.Cells(LastWrow + iRow, 1) = .Items.Item(iRow).SenderName
                Ws.Cells(LastWrow + iRow, 2) = .Items.Item(iRow).Subject
                Ws.Cells(LastWrow + iRow, 3) = .Items.Item(iRow).ReceivedTime
                Ws.Cells(LastWrow + iRow, 4) = .Items.Item(iRow).Categories
            Next iRow
        End If
    End With
Next folder

MsgBox "Outlook Mails Extracted to Excel"

End Sub