Question

此代码检查SEND上的特定电子邮件地址（显示一个简单的“是/否”消息框以便发送）。

代码在发送新电子邮件时有效，但在回复编码的电子邮件地址时失败。

当新电子邮件 - Debug.Print收件人显示电子邮件地址时当回复电子邮件 - Debug.Print收件人为空。

如果我在点击“回复”后添加收件人，则SEND事件将起作用。

显然，当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 Collection找到解决方案：

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

检查输入.To Works发送新电子邮件但不响应

1 个答案: