执行 Excel VBA 代码时禁用 Outlook 安全警告

Question

我的最终目标是在 Outlook 或 MS Exchange 中提供有关联系人的任何信息，并在不遇到任何警告消息的情况下获取他们的姓名和电子邮件地址。

我开发了一个运行良好的功能，除了我从Outlook Object Model Guard (OMG) 收到弹出警告消息的部分，我需要绕过它而不使用任何付费加载项、CDP、兑换或更改设置在 Outlook 应用程序（信任中心）等中的程序访问中。

我的代码在 Excel VBA 中，我没有提前绑定到 Outlook 库。

我知道访问某些对象或方法会触发OMG 弹出警告并等待用户确认。我想知道有没有一种方法可以在 VBA 中以编程方式禁用OMG，然后再启用它？

Excel VBA 函数：

Public Function GetContactObject2(strInput As String) As Object
    Dim chk As Boolean
    Dim sEmailAddress As String
    Dim olApp As Object
    Dim olNS As Object 'NameSpcase OL identifiers
    Dim olAL As Object 'AddressList An OL address list
    Dim olRecip As Object 'Outlook Recipient Object
    Dim olAddrEntry As Object 'AdressEntry An Address List entry
    Dim olCont As Object 'ContactItem An Outlook contact item
    Dim olExchUser As Object 'outlook Exchange User Object
    Dim obj As Object
    Dim oPA As Object

    chk = True 'assume everything is running fine
    Err.Clear

    'On Error GoTo Handler
    Set olApp = GetObject(, "Outlook.Application")

    'If an instance of an existing Outlook object is not available, an error will occur (Err.Number = 0 means no error):
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If

    Set olNS = olApp.GetNamespace("MAPI")
    'Set olAL = olNS.AddressLists("Global Address List")
    Set olRecip = olNS.createrecipient(strInput)
    olRecip.Resolve 'this line will cause Outlook Security Manager to pop up a message to allow or deny access to email

    'Check if the entry was resolved
    If olRecip.Resolved Then
        Set olAddrEntry = olRecip.AddressEntry
        Set olCont = olAddrEntry.GetContact

        If Not (olCont Is Nothing) Then
            'this is a contact
            'olCont is ContactItem object
            MsgBox olCont.FullName
        Else
            Set olExchUser = olAddrEntry.GetExchangeUser
            If Not (olExchUser Is Nothing) Then
                'olExchUser is ExchangeUser object
                'MsgBox olExchUser.PrimarySmtpAddress
                Set obj = olExchUser
            Else
                Set obj = Nothing
            End If
        End If
    Else 'Recipient was not found at all in the Global Address List
        Set obj = Nothing
    End If
    On Error GoTo 0

    Set GetContactObject2 = obj
    Exit Function
Handler:
    MsgBox "Err #: " & Err.Number & vbNewLine & Err.Description
End Function

调用第一个函数的 Excel VBA 函数 2：

    '=========================================
    ' Get Current User Email Address Function
    '=========================================
    ' Gets current user's email address using outlook MAPI namespace
    ' RETURNS: user email if found, otherwise a zero-length string
    Public Function GetCurrentUserEmailAddress2() As String
        Dim chk As Boolean
        Dim strInput As String 'any string that can be resolved by outlook to retrieve contact item
        Dim sEmailAddress As String
        Dim olApp As Object
        Dim olNS As Object
        Dim obj As Object 'object for contact

        chk = True 'assume everything is running fine
        Err.Clear

        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")

        'if an instance of an existing Outlook object is not available, an error will occur (Err.Number = 0 means no error):
        If Err.Number <> 0 Then
            Set olApp = CreateObject("Outlook.Application")
        End If


        '''' Set olNS = olApp.GetNamespace("MAPI")
        'This line will cause Outlook to pop a warning window that a program wants to have access your email address
        '''' sEmailAddress = olNS.Accounts.Item(1).SmtpAddress


        'Get a contact object and then extract the email from there
        'NOTE: some users' alias is their windows login, but some have different alias so it may fail. The best bet is finding the
        'email address using some other way and using it as the input which will almost never fail


        strInput = olApp.Session.CurrentUser.Address
        Set obj = GetContactObject2(strInput)

        If obj Is Nothing Then
            'Try one more time with windows login
            strInput = Environ("UserName")
            Set obj = GetContactObject2(strInput)
            If obj Is Nothing Then
                chk = False
            Else
                sEmailAddress = obj.PrimarySmtpAddress
            End If
        Else
            sEmailAddress = obj.PrimarySmtpAddress
        End If

        'Return a zero length string if by any chance email could not be retrieved, else validate it
        If chk = True Then
            chk = ValidateEmailAddress(sEmailAddress, bShowMessage:=False)
        Else
            sEmailAddress = ""
        End If

        On Error GoTo 0

        'Assign string to function
        GetCurrentUserEmailAddress2 = sEmailAddress

    End Function

Answer 1

如果您只需要当前用户的电子邮件地址，我会使用 Active Directory。您的所有用户至少应该能够读取 AD 中的值。

查看this post如何在VBA代码中查询AD。

注意：电子邮件属性的名称为mail、documentation。因此，您必须将链接中的代码更改为attr = "mail" 和WScript.Echo rs.Fields("mail").Value

旁注：我强烈建议任何开发人员安装RSAT，以便他们可以使用 MMC 验证 AD 中的值。