Private Sub Application_NewMailex(ByVal EntryIDCollection As String)
Путь = "E:\MAIL\Входящие\" 'папка для сохранения вложения
Set oNamespace = Application.GetNamespace("MAPI")
Dim arr() As String
Dim i As Integer
Dim m As MailItem
On Error Resume Next
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set m = Application.Session.GetItemFromID(arr(i))
If UCase$(m.SenderEmailType) = "EX" Then
Set recip = oNamespace.CreateRecipient(m.SenderEmailAddress)
Set exUser = recip.AddressEntry.GetExchangeUser()
sAddress = exUser.PrimarySmtpAddress
Else
sAddress = m.SenderEmailAddress
End If
t = iname(sAddress)
If t = "" Then t = m.SenderName
m.SentOnBehalfOfName = t
m.Save
If m.Attachments.Count > 0 Then
If Len(Dir(Путь & t, vbDirectory)) = 0 Then 'проверка существования директории
MkDir Путь & t 'делаем папку с t
End If
For j = 1 To m.Attachments.Count
m.Attachments.Item(j).SaveAsFile Путь & t & "\" & Date & " " & m.Attachments.Item(j).DisplayName
Next j
End If
m.UnRead = False
Next
End Sub

Function iname(t)
'On Error Resume Next
Dim myNameSpace As NameSpace
Dim myFolder As MAPIFolder
Dim myWorkFolder As MAPIFolder
Dim iContact As ContactItem
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myWorkFolder = myFolder
For Each iContact In myWorkFolder.Items
'Debug.Print iContact.Email1Address & "---->" & UCase$(iContact.Email1AddressType)
If UCase$(iContact.Email1AddressType) = "EX" Then
Set recip = myNameSpace.CreateRecipient(iContact.Email1Address)
Set exUser = recip.AddressEntry.GetExchangeUser()
sAddress = exUser.PrimarySmtpAddress
Else
sAddress = iContact.Email1Address
End If
If sAddress = t Then iname = iContact
Next iContact
End Function