自动化Outlook邮件发送前的联系人验证检查

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim objRecip As Recipient
    Dim objContact As ContactItem
    Dim strExternal As String

    If Item.MessageClass Like "IPM.TaskRequest*" Then
        Set Item = Item.GetAssociatedTask(False)
    End If

    strExternal = ""
    For Each objRecip In Item.Recipients
        Set objContact = FindContactByAddress(objRecip.Address)
        If objContact Is Nothing Then
            If LCase(objRecip.Address) Like "/o=*" Then
             strExternal = strExternal & "[HP Company]:" & objRecip.Name & vbCr
            Else
             strExternal = strExternal & "[Other Company]" & objRecip.Name & vbCr
            Endif
        Else
            strExternal = strExternal & "[HP Company]" & objRecip.Name & vbCr
        End If
    Next

    If strExternal <> "" Then
MSGText = "Title: [" & Item.Subject & "]" & vbCr & "The followings are mail addresses.Are they OK?" & _
 vbLf & "Receiver:" & vbCr & strExternal
        If MsgBox(MSGText, vbYesNo,"Name Cheking") = vbNo Then
            Cancel = True
        End If
    End If