Sub УдаляетПисьмаНеОтКомпании()
On Error GoTo ErrorHandler

Dim olApp As Outlook.Application
Dim Itms As Outlook.Items
Dim taskItm As Outlook.TaskItem
Dim mailItm As Outlook.MailItem
Dim i As Long

  Set olApp = GetOutlookApp

  ' Inbox folder
  Set Itms = GetItems(GetNS(olApp), olFolderInbox)

  For i = Itms.Count To 1 Step -1
    If IsMail(Itms.Item(i)) Then
      Set mailItm = Itms.Item(i)
      If ПоискКомпании(mailItm.SenderEmailAddress) = False Then
        mailItm.Delete
      End If
    End If
  Next i

'   удалить нежелательную почту
  Set Itms = GetItems(GetNS(olApp), olFolderJunk)

  For i = Itms.Count To 1 Step -1
    Itms.Item(i).Delete
  Next i

ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub



Function IsTask(itm As Object) As Boolean
  IsTask = (TypeName(itm) = "TaskItem")
End Function

Function IsMail(itm As Object) As Boolean
  IsMail = (TypeName(itm) = "MailItem")
End Function

Function GetItems(olNS As Outlook.NameSpace, folder As OlDefaultFolders) As Outlook.Items
  Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function

Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
  Set GetOutlookApp = Outlook.Application
End Function

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
  Set GetNS = app.GetNamespace("MAPI")
End Function