檢查條目.ToTo發送新電子郵件但不回覆

Question

此代碼檢查SEND上的特定電子郵件地址（顯示簡單的YES/NO消息框以發送或不發送）。

該代碼在發送新電子郵件時起作用，但在回覆編碼電子郵件地址時失敗。

當新電子郵件 - Debug.Print收件人顯示電子郵件地址。
當答覆電子郵件 - Debug.Print收件人爲空。

如果在單擊REPLY後添加收件人，則發送事件將起作用。

顯然，當Outlook填充TO（和CC）時，在SEND上未檢測到收件人（顯示爲空）。

據我所知，沒有「回覆」事件。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 
' code to verify if email is addressed to a specific email address/recipient 

'set appropriate objects 

Dim olApp As Outlook.Application 
Dim objNS As Outlook.NameSpace 
Dim objFolder As Outlook.MAPIFolder 
Dim Msg As Outlook.MailItem 
Dim sRecip As Outlook.Recipient 

Set olApp = Application 
Set objNS = olApp.GetNamespace("MAPI") 
Set Msg = Item 

'declare variables 
Dim str1 As String 
Dim str2 As String 
Dim str3 'this will be set as the specific email address 
Dim answer 

str1 = Msg.To 
str2 = Msg.CC 
str3 = "me@anywhere.com" 

' test to see if specific email address is in To or Cc 
If InStr(1, str1, str3) Or InStr(1, str2, str3) Then 
    answer = MsgBox("This email is addressed to = " & str3 & vbCrLf & vbCrLf & _ 
    "Are you sure you want to send this message?", vbYesNo, "SEND CONFIRMATION") 

    If answer = vbNo Then 
     Cancel = True 
    End If 
End If 

GoTo ErrorHandle 

ErrorHandle: 
Set Msg = Nothing 
Set objNS = Nothing 
Set objFolder = Nothing 
Set olApp = Nothing 

End Sub 

Answer 1

找到解決方案使用GetRecipients收藏：

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 

Dim msg As Outlook.MailItem 
Dim recips As Outlook.Recipients 
Dim str As String 
Dim prompt As String 

    Set msg = GetMailItem 
    Set recips = msg.Recipients 

    str = "me@anywhere.com" 
    For x = 1 To GetRecipientsCount(recips) 
    str1 = recips(x) 
    If str1 = str Then 
     MsgBox str1, vbOKOnly, str1 
     prompt = "Are you sure you want to send to " & str1 & "?" 
     If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 
     Cancel = True 
     End If 
    End If 
    Next x 
End Sub 

Public Function GetRecipientsCount(itm As Variant) As Long 
' pass in a qualifying item, or a Recipients Collection 
Dim obj As Object 
Dim recips As Outlook.Recipients 
Dim types() As String 

    types = Split("MailItem,AppointmentItem,JournalItem,MeetingItem,TaskItem", ",") 

    Select Case True 
    ' these items have a Recipients collection 
    Case UBound(Filter(types, TypeName(itm))) > -1 
     Set obj = itm 
     Set recips = obj.Recipients 
    Case TypeName(itm) = "Recipients" 
     Set recips = itm 
    End Select 

    GetRecipientsCount = recips.Count 
End Function