Question

所以我发现这个相当优雅的宏来从Outlook（在OfficeTricks.com上找到）发送电子邮件。

但是，它似乎只下载了1层子文件夹。有什么方法可以让我下载2或3层子文件夹吗？

Option Explicit
'This Code is Downloaded from OfficeTricks.com
'Visit this site for more such Free Code
Sub VBA_Export_Outlook_Emails_To_Excel()
    'Add Tools->References->"Microsoft Outlook nn.n Object Library"
    'nn.n varies as per our Outlook Installation
    Dim Folder As Outlook.MAPIFolder
    Dim sFolders As Outlook.MAPIFolder
    Dim iRow As Integer, oRow As Integer
    Dim MailBoxName As String, Pst_Folder_Name  As String

    'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
    MailBoxName = "Clauric@ABC.com"

    'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
    Pst_Folder_Name = "Inbox" 'Sample "Inbox" or "Sent Items"

    'To directly a Folder at a high level
    'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

    'To access a main folder or a subfolder (level-1)
    For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
        If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
        For Each sFolders In Folder.Folders
            If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
                Set Folder = sFolders
                GoTo Label_Folder_Found
            End If
        Next sFolders
    Next Folder

Label_Folder_Found:
     If Folder.Name = "" Then
        MsgBox "Invalid Data in Input"
        GoTo End_Lbl1:
    End If

    'Read Through each Mail and export the details to Excel for Email Archival
    ThisWorkbook.Sheets(1).Activate
    Folder.Items.Sort "Received"

    'Insert Column Headers
    ThisWorkbook.Sheets(1).Cells(1, 1) = "Sender"
    ThisWorkbook.Sheets(1).Cells(1, 2) = "Subject"
    ThisWorkbook.Sheets(1).Cells(1, 3) = "Date"
    ThisWorkbook.Sheets(1).Cells(1, 4) = "Size"
    ThisWorkbook.Sheets(1).Cells(1, 5) = "EmailID"
    ThisWorkbook.Sheets(1).Cells(1, 6) = "Body"

    'Export eMail Data from PST Folder to Excel with date and time
    oRow = 1
    For iRow = 1 To Folder.Items.Count
        'If condition to import mails received in last 60 days
        'To import all emails, comment or remove this IF condition
        If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
           oRow = oRow + 1
           ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
           ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
           ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
           ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
           ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Size
           ThisWorkbook.Sheets(1).Cells(oRow, 5) = Folder.Items.Item(iRow).SenderEmailAddress
           ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
        End If
    Next iRow
    MsgBox "Outlook Mails Extracted to Excel"
    Set Folder = Nothing
    Set sFolders = Nothing

End_Lbl1:
End Sub

当我尝试将Pst_Folder_Name更改为文件夹1层时，例如Pst_Folder_Name = "Operations"，它有效。但是，如果我尝试操作的子文件夹，例如Pst_Folder_Name = "Manufacturing"或Pst_Folder_Name = "Operations/Manufacturing"，我会得到一个

运行时错误消息'91'：对象变量或未设置块变量

在If Folder.Name = "" Then

Answer 1

如果您不是在寻找递归，而是手动引用树中较深的文件夹。

根据需要添加尽可能多的内容。

'To access a subfolder (level-1) or a subfolder (level-2)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders
    If VBA.UCase(Folder.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then GoTo Label_Folder_Found
    For Each sFolders In Folder.Folders
        If VBA.UCase(sFolders.Name) = VBA.UCase(Oneleveldeeper_Folder_Name) Then
            Set Folder = sFolders
            GoTo Label_Folder_Found
        End If
    Next sFolders
Next Folder

'To access a subfolder (level-2) or a subfolder (level-3)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name).Folders(Oneleveldeeper_Folder_Name).Folders
    If VBA.UCase(Folder.Name) = VBA.UCase(Twolevelsdeeper_Folder_Name) Then GoTo Label_Folder_Found
    For Each sFolders In Folder.Folders
        If VBA.UCase(sFolders.Name) = VBA.UCase(Twolevelsdeeper_Folder_Name) Then
            Set Folder = sFolders
            GoTo Label_Folder_Found
        End If
    Next sFolders
Next Folder

如何为Outlook子文件夹提取电子邮件

1 个答案: