Макрос Outlook VBA предотвращает запуск указанной учетной записи электронной почты

Question

Я пользуюсь учетной записью Office 365 Outlook. Сейчас я настроил 3 почтовых аккаунта. так как я создал макрос сценарий VBA. Я не хочу, чтобы этот скрипт работал во всех моих учетных записях электронной почты. Я хочу запускать VBA Script только в указанных учетных записях. Как этого добиться?

Например: предположим, три моих счета

• test@test.com,
• test1@test.com,
• test2@test.com.

Я хочу выполнить свой код VBA только в

• test@test.com,
• test1@test.com,

Не работает сценарий VBA на

• test2@test.com

Мой код: -

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Dim prompt As String
    Dim strMsg As String

    Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

    Set recips = Item.Recipients
    For Each recip In recips
        Set pa = recip.PropertyAccessor
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@newsdozens.com") = 0 Then
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@newsdozens2.com") = 0 Then
        If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@bnewstest.com") = 0 Then
            strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
        End If
        End If
        End If
    Next

    If strMsg <> "" Then
        prompt = "This email will be sent outside of newsdozens.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
        If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
            Cancel = True
        End If
    End If
End Sub

Answer 1

Существуют различные способы получения информации об отправителе. Это должно работать для адресов EX или SMTP.

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

    Debug.Print Item.SenderEmailAddress
    ' use text from the debug.print, that is unique to the account
    If InStr(Item.SenderEmailAddress, "test2") Then Exit Sub

    ' code here for all other accounts

End Sub

Answer 2

Вы можете проверить адрес электронной почты Отправителя в событии ItemSend и отменить любые дальнейшие действия, если для конкретной учетной записи не нужно запускать макросы VBA:

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

   If InStr(LCase(Item.SenderEmailAddress), "test2@test.com") = 0 Then Exit Sub

   Dim recips As Outlook.Recipients
   Dim recip As Outlook.Recipient
   Dim pa As Outlook.PropertyAccessor
   Dim prompt As String
   Dim strMsg As String

   Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

  Set recips = Item.Recipients
  For Each recip In recips
    Set pa = recip.PropertyAccessor
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@newsdozens.com") = 0 Then
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@newsdozens2.com") = 0 Then
    If InStr(LCase(pa.GetProperty(PR_SMTP_ADDRESS)), "@bnewstest.com") = 0 Then
        strMsg = strMsg & "   " & pa.GetProperty(PR_SMTP_ADDRESS) & vbNewLine
    End If
    End If
    End If
  Next

  If strMsg <> "" Then
    prompt = "This email will be sent outside of newsdozens.com to:" & vbNewLine & strMsg & "Do you want to proceed?"
    If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
        Cancel = True
    End If
  End If
End Sub

Answer 3

Чтобы выборочно запустить макрос, вы можете сделать что-то вроде следующего:

Dim Session As Outlook.NameSpace
Dim Accounts As Outlook.Accounts
Dim currentAccount As Outlook.Account

Set Session = Application.Session    
Set Accounts = Session.Accounts

For Each currentAccount In Accounts                    
    Debug.Print currentAccount.SmtpAddress

    If currentAccount.SmtpAddress <> "test2@test.com" Then
        '  call your macro
    End If
Next