从存储在许多子文件夹中的 *.msg 文件中提取附件

Question

下面的代码从存储在一个文件夹中的 *.msg 文件中提取附件。

我正在寻求从存储在文件夹内许多子文件夹中的 *.msg 文件中提取附件。

主文件夹的路径为：
U：\XXXXX\XXXXX\MAIN FOLDER

子文件夹的路径为：
U：\XXXXX\XXXXX\主文件夹\文件夹1
U：\XXXXX\XXXXX\主文件夹\文件夹2
U：\XXXXX\XXXXX\主文件夹\文件夹3
等。

Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
    'path for msgs
strFilePath = "U:XXXXXXXXXXMain Folder"
    'path for saving attachments
strAttPath = "DAttachments"
strFile = Dir(strFilePath & "*.msg")
Do While Len(strFile) > 0
    Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
    If msg.Attachments.Count > 0 Then
         For Each att In msg.Attachments
             att.SaveAsFile strAttPath & att.FileName
         Next
    End If
    strFile = Dir
Loop
End Sub

Answer 1

使用我在多个子文件夹中搜索文件的 VBA 宏中的答案

Sub SaveOlAttachments()
    Dim msg As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim strFilePath As String
    Dim strAttPath As String
    Dim colFiles As New Collection, f
    'path for msgs
    strFilePath = "U:XXXXXXXXXXMain Folder"
    GetFiles strFilePath , "*.msg", True, colFiles
    'path for saving attachments
    strAttPath = "DAttachments"
    For Each f in colFiles
        Set msg = Application.CreateItemFromTemplate(f)
        If msg.Attachments.Count > 0 Then
             For Each att In msg.Attachments
                 att.SaveAsFile strAttPath & att.FileName
             Next
        End If
    Next
End Sub

子执行搜索：

Sub GetFiles(StartFolder As String, Pattern As String, _
             DoSubfolders As Boolean, ByRef colFiles As Collection)
    Dim f As String, sf As String, subF As New Collection, s
    If Right(StartFolder, 1) <> "" Then StartFolder = StartFolder & ""
    f = Dir(StartFolder & Pattern)
    Do While Len(f) > 0
        colFiles.Add StartFolder & f
        f = Dir()
    Loop
    sf = Dir(StartFolder, vbDirectory)
    Do While Len(sf) > 0
        If sf <> "." And sf <> ".." Then
            If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
                    subF.Add StartFolder & sf
            End If
        End If
        sf = Dir()
    Loop
    For Each s In subF
        GetFiles CStr(s), Pattern, True, colFiles
    Next s
End Sub