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
