保存 Outlook 附件答案

【问题标题】：Saving Outlook Attachments保存 Outlook 附件
【发布时间】：2020-06-30 07:55:58
【问题描述】：

在 Outlook 中使用 VBA 并且在定位时正在努力处理分级文件夹，因为它似乎只适用于一个分级的“子级别”。我目前在我的 Outlook 中可能有一个 5 层文件夹组织，每天我都会收到许多带有需要归档附件的电子邮件。到目前为止，我正在使用我的第一个文件夹来提取附件并将它们归档到我创建的指定文件夹中，但由于子文件夹位于第 4 层，因此它不起作用。

Sub GetAttachments()
On Error GoTo GetAttachments_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
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("DZ1")
    i = 0
' Check Inbox for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
   MsgBox "There are no messages in the Sales Reports folder." _
   , vbInformation, "Nothing Found"
   Exit Sub
End If
' Check each message for attachments
    If SubFolder.Items.Count > 0 Then
    For Each Item In SubFolder.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
            FileName = "File path" & Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt
    Next Item
End If
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_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 GetAttachments_exit
End Sub

我能得到一些帮助吗？

干杯

【问题讨论】：

标签： vba outlook outlook-addin

【解决方案1】：

您需要重构代码，以便在文件夹中执行的操作采用递归方法，该方法在需要访问文件夹的 Folder.Folders 集合中的另一个文件夹时调用自身。

【讨论】：

【解决方案2】：

按照路径，就像您手动获取文件夹一样。

设置子文件夹 = Inbox.Folders("DZ1").Folders("DZ2").Folders("DZ3").Folders("DZ4")

【讨论】：

【解决方案3】：

仅搜索子文件夹实际上只会检查直接子文件夹。不是“孙子”。

您必须执行以下操作：

Sub subfolderrs_6_levels()
   Dim Ol, Mf, Mf1, mf2, Ns, mf3, mf4, mf5, mf6, I&
   On Error Resume Next
   For Each Mf In Ns.Folders
      call_your_routine(mf)
      I = I + 1
      For Each Mf1 In Mf.Folders
          call_your_routine(mf1)
      I = I + 1
         For Each mf2 In Mf1.Folders
           call_your_routine(mf2)
      I = I + 1
            For Each mf3 In mf2.Folders
            call_your_routine(mf3)
      I = I + 1
            For Each mf4 In mf3.Folders
            call_your_routine(mf4)
      I = I + 1
            For Each mf5 In mf4.Folders
            call_your_routine(mf5)
      I = I + 1
            For Each mf6 In mf5.Folders
            call_your_routine(mf6)
            Next
            Next
            Next
            Next
         Next
      Next
   Next
   Set Ns = Nothing: Set Mf1 = Nothing: Set Mf = Nothing: Set Ol = Nothing: 
   Set mf2 = Nothing: Set mf3 = Nothing: Set mf4 = Nothing: Set mf5 = Nothing: Set mf6 = Nothing
End Sub

sub call_your_routine(mf as Outlook.folder)
    For Each Item In SubFolder.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
            FileName = "File path" & Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt
    Next Item
end sub

【讨论】：