Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "L:\Мои документы\Информационные письма Росздравнадзора\"
For Each oAttachment In MItem.Attachments
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
Next
End Sub

Sub SaveAllAttachments(objitem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
strLocation = "Путь к папке"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
End If   ' put breakpoint on next line, then step through code to see if it enters loop
For dblLoop = 1 To dblCount
strName = strLocation & Replace(Mid(objitem.Subject, 26), "/", " ") & ".pdf"
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
'objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub