Macro para descargar archivos adjuntos masivamente Outlook

Ya tengo un código para descargar los adjuntos de outlook pero el problema es que yo he creado otro pst con ruta a mi disco duro, donde pongo todos mis correos cuando se llena mi bandeja de entrada.

Yo quiero modificar el código para que copie todo los archivos adjuntos pero del pst que he creado que tiene por nombre Bandeja y todas sus subcarpetas.

Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim SubFolder As MAPIFolder
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("PRUEBA")
i = 0
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in Prueba folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
If SubFolder.Items.Count > 0 Then
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
FileName = "D:\CORREO\ADJ\" & _
Format(Item.CreationTime, "dd mm yyyy_hh nn_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
End If
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the D:\CORREO\ADJ." _
& vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, _
"Finished!"
End If
End Sub