Save outlook attachments from an Outlook folder to a file folder with the same name

I need a function, which saves the attachments in the emails inside an outlook folder to a file folder on the drive with the same name. So lets say the outlook folder is named Cortina. The code looks through the folders to find if there are any files with attachments.  The following code achieves that.

So when the code realizes there is a new file with an attachment inside the folder, it will take that file and save it under c:\roberto\cortina

SO if the outlook folder was named roddick than the path would have been c:\roberto\roddick.

how can I achieve this?

Sub GoToProjectsFolder()
'Makes the "Projects" folder the active folder in the current instance of Outlook
'v1.00 28Jun2007
    Dim myolApp As Outlook.Application
    Dim mynamespace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim found As Boolean
    Dim strFolderName As String
Dim oltempitem As Object
Dim atmt As Attachment
Dim filename As String
Dim filefolder As String

    'specify the folder you are looking for
    strFolderName = "Inbox"
    
   
    Set myolApp = GetObject(, "Outlook.Application")
    Set mynamespace = myolApp.GetNamespace("MAPI")
    
    
    Set myFolder = mynamespace.Folders("Mailbox - Ruben Cortina").Folders("Clients")
    
   For i = 1 To myFolder.Folders.Count
For j = 1 To myFolder.Folders(i).Items.Count


'myFolder.Folders.Ite

'   MsgBox myFolder.Folders(i)
'myFolder.Folders (i)
   Set oltempitem = myFolder.Folders(i).Items(j)
    If myFolder.Folders(i).Items(j).Attachments.Count > 0 Then

For Each atmt In myFolder.Folders(i).Items(j).Attachments
'
'MsgBox myFolder.Folders(i).Items(j).EntryID
'
'myFolder.Folders(i).Items(j).EntryID
    
   


Next
'MsgBox oltempitem.Subject
End If

   
   Next
    
Next
    
'   For i = 1 To (mynamespace.Folders.Count)
   

    Set myolApp = Nothing
    Set mynamespace = Nothing
    
    
    
End Sub

Select allOpen in new window