Extracting Attachments from *.msg files stored in many subfolders

Question

The below code extracts attachments from *.msg files stored in one folder.

I'm seeking to extract attachments from *.msg files stored in many subfolders within a folder.

The path for the main Folder is:
U:\XXXXX\XXXXX\Main Folder

The paths for the subfolders are:
U:\XXXXX\XXXXX\Main Folder\Folder1
U:\XXXXX\XXXXX\Main Folder\Folder2
U:\XXXXX\XXXXX\Main Folder\Folder3
etc.

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:\XXXXX\XXXXX\Main Folder\"
    'path for saving attachments
strAttPath = "D\Attachments\"

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

https://stackoverflow.com/questions/20687810/vba-macro-that-search-for-file-in-multiple-subfolders/20688126#20688126 — Tim Williams, Jan 11 '18 at 06:39
Thanks a lot Tim for your prompt response. Much appreciated. As my VBA knowledge is limited, can you do me a favor & combine the two code together. Thank you again Tim :) — Obada Talal, Jan 11 '18 at 06:54
Possible duplicate of [VBA macro that search for file in multiple subfolders](https://stackoverflow.com/questions/20687810/vba-macro-that-search-for-file-in-multiple-subfolders) — F0XS, Jan 11 '18 at 06:55
Thank you FoxCy. I would be grateful if the codes can be combined together to extract all the attachments from the resulted *.msg files. Appreciated. — Obada Talal, Jan 11 '18 at 07:08

Tim Williams · Accepted Answer · 2018-01-12T06:24:33.537

Using my answer from VBA macro that search for file in multiple subfolders

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:\XXXXX\XXXXX\Main Folder\"

    GetFiles strFilePath , "*.msg", True, colFiles

    'path for saving attachments
    strAttPath = "D\Attachments\"

    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 to perform the search:

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

Thanks a lot Tim for your efforts. I tried the code but I'm getting Compile error, Sub or Function not defined. Any thoughts from your side? — Obada Talal, Jan 12 '18 at 05:59
Did you copy the `GetFiles` sub from the linked question? I've added it above. — Tim Williams, Jan 12 '18 at 06:23
It worked amazingly! Thank you so much Tim. Wish you all the best in your life & career. Have a great day ahead! — Obada Talal, Jan 16 '18 at 05:03

Extracting Attachments from *.msg files stored in many subfolders

1 Answers1

Linked