Ftyjtk

I'm seeking your kind support to revise the below code to extract Attachments from *.msg files stored in many subfolders within main Shared Folder.

The below code is working fine for *.msg files if stored in one folder, but can't work for *.msg files stored in the subfolders.

The path for the main Folder is:

U:XXXXXXXXXXMain Folder

The paths for the subfolders are:

U:XXXXXXXXXXMain FolderFolder1

U:XXXXXXXXXXMain FolderFolder2

U:XXXXXXXXXXMain FolderFolder3
..etc.

Below is the code:

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

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: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 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