Sub save_new()
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")
DestFolder = "C:\New\"
        
If myFolder.Items.Count > 0 Then
    For i = 1 To myFolder.Items.Count
        If myFolder.Items(i).Attachments.Count > 0 Then
            For j = 1 To myFolder.Items(i).Attachments.Count
                myFolder.Items(i).Attachments.Item(j).SaveAsFile DestFolder & myFolder.Items(i).Attachments.Item(j).DisplayName
            Next j
        End If
    Next i
End If
End Sub

Sub сохранение()
Dim myobj As Object
Dim att As Attachment
Dim CD As String
Dim D As String


For Each myobj In Application.ActiveExplorer.Selection
If myobj.Class = olMail Then
    For Each att In myobj.Attachments
        D = att.FileName
        If D = Dir("D:\Attachments\" & att.FileName) Then
            att.SaveAsFile "D:\Attachments\" & Format(Date, "yyyy_dd_mm_") & att.FileName
            Else
            att.SaveAsFile "D:\Attachments\" & att.FileName
        End If
    Next
End If
Next
End Sub