Private Sub Application_NewMail()
On Error Resume Next
Dim myolApp As Outlook.Application
Dim myItem As Outlook.MailItem
Set myolApp = CreateObject("Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
last_count = myFolder.Items.Count
Set myItem = myFolder.Items(last_count)
Set myeitems = myItem.Attachments
'  myFolder.Items.Sort "ReceivedTime", false
For i = 0 To myeitems.Count
 ' If myeitems.Count > 0 Then
 ' If (Right(myeitems(i).DisplayName, 3) = "xls") And (myFolder.Items(i).UnRead = True) Then  Then
  myeitems(i).SaveAsFile "C:\Temp\" & myeitems(i).DisplayName
 ' End If
 ' End If
Next i
myeitem.Delete
For i = 0 To myeitems.Count
  myeitems(i).Delete
Next i
End Sub

For i = 0 To myeitems.Count
  myeitems(i).Delete
Next i

Sub Perekrest_Attach_Proc01()
'папки "Perekrest_Raw" и "Perekrest_Processed" должны уже быть созданы в папке "Входящие"!!!
'
R = MsgBox("Хотите обработать  письма  от Перекресток?", vbYesNo, "обработка сообщений")
If R = vbNo Then Exit Sub 
Dim myApp As  Outlook .Application 
Dim myFolder As  Outlook .MAPIFolder 
Dim myItem As Object 
Set myOlApp = CreateObject(" Outlook .Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI") 
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Perekrest_Raw")' исходные сообщения, которые обрабатываются 
Set otherFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("Perekrest_Processed")' обработанные сообщения 
DestFolder = "C:\Perekrest_Attach\" ' эта папка тоже уже должна существовать!!!
'Выцепляем аттачи  из   писем  в исходной папке, сохраняем их в папку на ЖД 
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
	
	'Переносим обработанные письма в папку для обработанных сообщений - чтобы больше не мешались 
	For Each myItem In myFolder.Items
	myItem.Move otherFolder
	Next
End If
	MsgBox "Обработка завершена!"
End Sub

Private Sub Application_NewMail()
Dim myolApp As Outlook.Application
Dim myItem As Outlook.MailItem
Set myolApp = CreateObject("Outlook.Application")
Set myNamespace = myolApp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Dim last_count As Integer
last_count = myFolder.Items.Count
Set myItem = myFolder.Items(last_count)
Set myeitems = myItem.Attachments
For i = 1 To myeitems.Count
  myeitems(i).SaveAsFile "C:\Temp\" & myeitems(i).DisplayName
Next i
For i = 1 To myeitems.Count
  myItem.Attachments.Remove (i)    ' не работает
  myeitems(i).Delete                       ' не работает
Next i
End Sub