Disable outlook security warning when executing an Excel VBA code

Question

My ultimate goal is to give any piece of information on contacts in Outlook or MS Exchange and get their name and email address without encountering any warning message.

I have developed a function that works well except for the part that I am getting a pop up warning message from Outlook Object Model Guard (OMG) and I need to skirt around it without using any paid add-in,CDP, Redemption or changing the setting in Programmatic access in Outlook application (Trust Center) etc.

My code is in Excel VBA and I am not doing an early binding to the Outlook library.

I know accessing some objects or methods will trigger the OMG to popup a warning and wait for a confirmation from the user. I was wondering there is a way to pro grammatically in VBA disable OMG and then enable it afterwards?

Excel VBA Function:

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 Function 2 that calls the first function:

    '=========================================
    ' 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

If all you need is the current users email address, I would use Active Directory. All your users should be able to at least read the values from AD.

See this post as to how to query AD in VBA code.

Note: the name of the email attribute is mail, documentation. So, you have to change the code in the link to attr = "mail" and WScript.Echo rs.Fields("mail").Value

Side note: I highly suggest any developer install RSAT so that they can verify values in AD by using MMC.

Answer 2

You need to either make sure an up-to-date AV app is installed, or (if you cannot control the environment), a utility like ClickYes to simulate a mouse click on the security prompt or a library like Redemption (I am its author) to bypass the prompt programmatically.

See http://www.outlookcode.com/article.aspx?id=52 for the detailed list of your options.