Excel VBA to find Sub Folder Level 3 and Save Attachemetns

[ScottUlmer]

Hello. I got the bulk of what I want done, but I can't quite get it there. The code I have works (from my research is called) Level 2 in outlook. Example: email@email.com/Inbox/Level 2. And this is great but what I really need it to do is have it work at Level 3 email@email.com/Inbox/Level 2/Level 3. My "real" example would be Social/Test. I tried all the combinations I could think of to get this work but just won't dig down enough. I tried "Social/Test", "Test", calling Social and Test in different sports and even "SocicalTest". Below is the working code for Level 3.

Sub AAA()'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
'        If you use "" it will create a date/time stamped folder for you in your "Documents" folder
'        Note: https://www.rondebruin.nl/win/s1/outlook/saveatt.htm
'Tip: Create a mail rule in Outlook (Tools>Rules and Alerts) and move the mail from ? or with the
'subject ? to the folder in your Inbox named "MyFolder" when the mail arrived.
'Note: You can also move the files from your Inbox to the folder "MyFolder" manual.


    SaveEmailAttachmentsToFolder "Test", "", "C:\Users\User\Desktop"
    
End Sub


Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
                                 ExtString As String, DestFolder As String)
    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 MyDocPath As String
    Dim i As Integer
    Dim wsh As Object
    Dim FS As Object
    Dim S As Integer
    Dim ItemCount As Integer
    Dim ItemCountTotal As Integer
    
    On Error GoTo ThisMacro_err


    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    'Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
    Set SubFolder = Inbox.Folders(OutlookFolderInInbox)




    i = 0
    ' Check subfolder for messages and exit of none found
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
               vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If


    'Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set FS = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.SpecialFolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not FS.FolderExists(DestFolder) Then
            FS.CreateFolder DestFolder
        End If
    End If


    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If
    ' Check each message for attachments and extensions
    
    
    'MsgBox (SubFolder.Items.Count)
    ItemCount = 0
    TotalItemCount = SubFolder.Items.Count
    
    For Each Item In SubFolder.Items
    If ItemCount < TotalItemCount - 3 Then
    'Total number of emails I want is 3
    ItemCount = ItemCount + 1
    Else
    
    
        'I should make it i to 3
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                'FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                FileName = DestFolder & Atmt.FileName
                Atmt.SaveAsFile FileName
                i = i + 1
            End If
        Next Atmt
        
        ItemCount = ItemCount + 1
        End If
       
    Next Item


    
    
    


    ' Show this message when Finished
    If i > 0 Then
        MsgBox "You can find the files here : " _
             & DestFolder, vbInformation, "Finished!"
    Else
        MsgBox "No attached files in your mail.", vbInformation, "Finished!"
    End If


    ' Clear memory
ThisMacro_exit:
    Set SubFolder = Nothing
    Set Inbox = Nothing
    Set ns = Nothing
    Set FS = Nothing
    Set wsh = Nothing
    Exit Sub


    ' Error information
ThisMacro_err:
    MsgBox "An unexpected error has occurred." _
         & vbCrLf & "Please note and report the following information." _
         & vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume ThisMacro_exit


End Sub

I found a way to FIND Level 3 but no way to call it

Sub Level3()

    'Needs reference to MS Outlook Object Library
    
    Dim olApp As Outlook.Application
    Dim olNs As Outlook.Namespace
    Dim olParentFolder As Outlook.MAPIFolder
    Dim olFolderA As Outlook.MAPIFolder
    Dim olFolderB As Outlook.MAPIFolder
    
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")


    Set olParentFolder = olNs.Folders("scotttheu@hotmail.com").Folders("Inbox")


    For Each olFolderA In olParentFolder.Folders
    'MsgBox (olFolderA)
    'Level 1 subfolders
        Debug.Print olFolderA.FolderPath, olFolderA.Items.Count, olFolderA.Folders.Count
        For Each olFolderB In olFolderA.Folders
        'MsgBox (olFolderB)
        a = (olFolderA.FolderPath)
            Debug.Print olFolderB.FolderPath, olFolderB.Items.Count
        Sheets(1).Range("a1").Value = (a & "\" & olFolderB)
        Next
    Next
End Sub

What I want from the second code is what the value of olFolderB. I think the part of the first code I need to get to match what olFolderB is Set SubFolder = Inbox.Folders(OutlookFolderInInbox) and/or SaveEmailAttachmentsToFolder "Test". Any ideas? thank you for your time.

 

[ScottUlmer]

so this return the correct folder and item count (so I think it is hitting the right spot), I just can't seem to call it. I can only call folders that are 1 more than Inbox.

    Set SubSubFolder = SubFolder.Folders("Test")    'MsgBox (SubSubFolder)
    MsgBox (SubSubFolder.FolderPath)