宏从Outlook子子文件夹中将电子邮件附件保存到硬盘驱动器

Question

我是初学者VBA程序员，但我已经让一个模块运行良好。它会扫描子文件夹，查找带有pdf附件的电子邮件，并将其保存到共享硬盘上的特定文件夹中。

我粘贴了下面的代码。

我的问题是，我希望宏扫描子文件夹中子文件夹中的子文件夹。基本上，我对Outlook中的规则非常具体。

我的麻烦在于我无法弄清楚如何安排第21行：

"Set SubFolder = Inbox.Folders("Palo Park")"以指定我的子子文件夹。

在我的收件箱下，我的子文件夹如下所示：收件箱＆gt; Palo Park＆gt; Submittals＆gt;来自Arch的Subm。 See Image。

这是来自Arch＆＃34;的这个＆＃34; Subm我希望代码扫描附件的子文件夹。

我是否以某种方式使用FolderPath？我是否以某种方式键入路径("Palo Park\Submittals\Subm from Arch\")?

Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Sales Reports" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
    On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
    Dim ns As NameSpace
 Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Palo Park")
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the Subm from Arch folder.", vbInformation, _
           "Nothing Found"
    Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "pdf" extension
        If Right(Atmt.FileName, 3) = "pdf" Then
        ' This path must exist! Change folder name as necessary.
            FileName = "S:\1- Job Files - Active\# 3034 - BHP Palo Park\07 - Submittals\Submittals from Architect\" & _
                Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
        End If
    Next Atmt
Next Item
' Show summary message
If i > 0 Then
    varResponse = MsgBox("I found " & i & " attached files." _
    & vbCrLf & "I have saved them into the S:\1- Job Files - Active\# 3034 - BHP Palo Park\07 - Submittals\Submittals from Architect folder." _
    & vbCrLf & vbCrLf & "Would you like to view the files now?" _
    , vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
    If varResponse = vbYes Then
        Shell "Explorer.exe /e,S:\1- Job Files - Active\# 3034 - BHP Palo Park\07 - Submittals\Submittals from Architect\", vbNormalFocus
    End If
Else
    MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
    & vbCrLf & "Please note and report the following information." _
    & vbCrLf & "Macro Name: GetAttachments" _
    & vbCrLf & "Error Number: " & Err.Number _
    & vbCrLf & "Error Description: " & Err.Description _
    , vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub

Answer 1

Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Palo Park")
Set SubSubFolder = SubFolder.Folders("Submittals")
Set SubSubSubFolder = SubSubFolder.Folders("Subm from Arch")

或（更简单）

Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Palo Park").Folders("Submittals").Folders("Subm from Arch")