VBA code to save Outlook attachments to multiple subdirectories

See more:

Outlook

VBA

I am trying to write a script that will save a copy of the attachment to all sub-directories of a folder, but only to the initial sub-directories (for example, c:\Temp and all its sub-directories such as C:\Temp\Sub, but not to a folder such as C:\Temp\Sub\Dir.

Another suitable solution is that if I put multiple directories in a variable, then put the attachment into those directories.

This is what I have so far:

Sub SaveSelected()
'Declaration
Dim myItems, myItem, myAttachments, myAttachment
Dim myOrt As String
Dim myOLApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim objFSO As Object
Dim intCount As Integer

'Ask for destination folder
'myOrt = "\\file4\\shared\\itarf\\"
myOrt = "C:\\temp\\"

'On Error Resume Next

Set objFSO = CreateObject("Scripting.FileSystemObject")

'work on selected items
Set myOlExp = myOLApp.ActiveExplorer
Set myOlSel = myOlExp.Selection

'for all items do...
For Each myItem In myOlSel

'point on attachments
Set myAttachments = myItem.Attachments

'if there are some...
If myAttachments.Count > 0 Then

'add remark to message text
myItem.Body = myItem.Body & vbCrLf & _
"E-mail Attachment(s): Automatically Saved to Location Below" & vbCrLf

'for all attachments do...
For i = 1 To myAttachments.Count
   strFileName = myAttachments(i).DisplayName
   strPriorFileName = strFileName
   intCount = 1
Do While True
   strFileName = InputBox("Type in the name to save the ITARF as. Please use the <last name>,<first name>_<year><month><date>.??? format.", "Save Attachments", strFileName)
   If objFSO.FileExists(myOrt & strFileName) Then
      strFileName = objFSO.GetBaseName(myOrt & strFileName) & "(" & intCount & ")." & objFSO.GetExtensionName(myOrt & strFileName)
      intCount = intCount + 1
   Else
      myAttachments(i).SaveAsFile myOrt & strFileName
   Exit Do
End If
Loop

'add name and destination to message text
myItem.Body = myItem.Body & "File: " & strPriorFileName & " saved as " & myOrt & strFileName & vbCrLf

Next i

'for all attachments do...
While myAttachments.Count > 0

myAttachments(1).Delete

Wend

'save item without attachments
myItem.Save
End If

Next

'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOLApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub