Проверка записи в .To работает отправка нового электронного письма, но не при ответе - PullRequest
Новая
       8

Проверка записи в .To работает отправка нового электронного письма, но не при ответе

1 голос
/ 01 февраля 2012

Этот код проверяет наличие определенного адреса электронной почты при отправке (отображает простое окно сообщения ДА / НЕТ, отправлять или нет).

Код работает при отправке НОВОГО электронного письма, но не работает при ОТВЕТЕ на закодированное электронное письмоадрес.

Когда Новое электронное письмо - получатель Debug.Print отображает адрес электронной почты.
Когда Ответное электронное письмо - получатель Debug.Print имеет нулевое значение.

Если я добавлю получателя после нажатия кнопки ОТВЕТИТЬ, событие ОТПРАВИТЬ сработает.

Очевидно, что когда Outlook заполняет TO (и CC), получатели не обнаруживаются (считаются нулевыми) при отправке.

Насколько я знаю, нет события "Ответить". 

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

1 Ответ

0 голосов
/ 02 февраля 2012

Найдено решение с использованием коллекции 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
...