用Outlook联系人中的FileAs名称替换“从”，“到”，“抄送”字段

Question

我想用Outlook联系人中的FileAs名称替换“发件人”，“收件人”，“抄送”字段。我在互联网上搜索并混合了代码。

1）当我在Outlook中选择几封电子邮件并运行代码ContactCategoriesManual()时，它可以工作。但是，如果选择了日程表请求，则代码将停止并显示错误消息。
有什么方法可以只识别选择中的电子邮件并运行代码而不会出现错误消息？

2）当Outlook收到几封电子邮件时，代码中将显示一条错误消息，并弹出一些“退出”，“调试”按钮。
当我单击“调试”时，以下行将突出显示。

If Item.SenderEmailType = "SMTP" Then

当我检查新电子邮件时，它们都是SMTP。奇怪的是，如果我为新电子邮件运行代码ContactCategoriesManual()，它就会起作用。

Option Explicit

Private WithEvents olInboxItems As Outlook.Items

Private Sub Application_Startup()
    Dim outlookApp As Outlook.Application
    Dim objectNS As Outlook.NameSpace

    Set outlookApp = Outlook.Application
    Set objectNS = outlookApp.GetNamespace("MAPI")
    Set olInboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub


Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
    Dim oContact As Outlook.ContactItem
    Dim oSender As String
    Dim folContacts As Outlook.MAPIFolder
    Dim colItems As Outlook.Items
    Dim oNS As Outlook.NameSpace
     
    Set oNS = Application.GetNamespace("MAPI")
    Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
    Set colItems = folContacts.Items

    If Item.SenderEmailType = "SMTP" Then
        oSender = Item.SenderEmailAddress
    Else
        If Item.SenderEmailType = "EX" Then
            oSender = Item.Sender.GetExchangeUser.PrimarySmtpAddress
        End If
    End If

    If Not (oSender = vbNullString) Then

        Set oContact = colItems.Find("[Email1Address] = '" & oSender & "' or [Email2Address] = '" & oSender & "' or [Email3Address] = '" & oSender & "'")

        Sender = vbNullString

        If Not oContact Is Nothing Then
            Item.SentOnBehalfOfName = oContact.FileAs
            Set oContact = Nothing
            Item.Save
        Else
          
        End If

        Set Item = Nothing
    End If

    Set folContacts = Nothing
    Set colItems = Nothing
    Set oNS = Nothing

End Sub


Public Sub ContactCategoriesManual()
    Dim objMail As Object

    For Each objMail In Application.ActiveExplorer.Selection
        olInboxItems_ItemAdd objMail
        Set objMail = Nothing
    Next

End Sub