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

Question

我是一名初学VBA程序员，但我已经获得了一个运行良好的模块。它扫描PDF文件附件中的电子邮件子文件夹，并将它们保存到共享硬盘上的特定文件夹中。

我粘贴下面的代码。

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

我的问题是，我无法弄清楚如何安排行21：

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

在我的收件箱中，我的子文件夹如下所示：收件箱>帕洛帕克> Submittals> Arch中的Subm。 See Image。

正是这种“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")