Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
dateOfMailItem = Format(itm.ReceivedTime, "yyyy.mm.dd")
saveFolder = "C:\Users\Admin\Pictures\analiz"
 If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
 End If
For Each objAtt In itm.Attachments
'Проверяем наличие файла с таким же именем
j = " "
  For i = 1 To 1000
   If Not Dir(saveFolder & "\" & dateOfMailItem & j & objAtt.FileName) = "" Then
    j = "_" & i & "_"
   Else
    Exit For
   End If
  Next i
'Конец проверки
objAtt.SaveAsFile saveFolder & "\" & dateOfMailItem & j & objAtt.FileName
Set objAtt = Nothing
Next
End Sub