Sub Íîâûå()
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim NewFolder As String
Dim myApp As Outlook.Application
Dim myFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("1")
NewFolder = "E:\Темп\"
'Èùåì â ïî÷òå

If myFolder.Items.Count >  0  Then
    For I = myFolder.Items.Count To  1  Step - 1 
        If myFolder.Items(I).Attachments.Count >  0  Then
           For j =  1  To myFolder.Items(I).Attachments.Count
               'myFolder.Items(I).Attachments.Item(j).SaveAsFile FolderSave & myFolder.Items(I).Attachments.Item(j).DisplayName
                n = myFolder.Items(I).Attachments.Item(j).DisplayName
                Workbooks.Open n
                name_outlook = ActiveWorkbook.Name
           Next j
        End If
    Next I
End If


End Sub

Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Отчеты")
Set myFolder1 = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Отчеты").Folders("Отработанные")
.....
myFolder.Items(i).Copy myFolder.myFolder1