Tweet
Hi,
I have the following code which works as I need by looking at the name entered in a cell, looking this up in the Global Address List and returning the address string in the next cell.
The issue is that the address string is as the following example: /o=XYZ Corporation/ou=ae/cn=Recipients/cn=john.mcenzie
Help needed:
1. I want to cut this GAL returned string down to just the actual e-mail address if possible, i.e. john.mcenzie.
2. Stop the Outlook security prompt.
3. All of the above but in a tidier and more efficient coding
Many Thanks in advance.
I have the following code which works as I need by looking at the name entered in a cell, looking this up in the Global Address List and returning the address string in the next cell.
The issue is that the address string is as the following example: /o=XYZ Corporation/ou=ae/cn=Recipients/cn=john.mcenzie
Help needed:
1. I want to cut this GAL returned string down to just the actual e-mail address if possible, i.e. john.mcenzie.
2. Stop the Outlook security prompt.
3. All of the above but in a tidier and more efficient coding
Code:
Dim Outlook As Object
Const olFolderContacts As Long = 10
Private Sub Worksheet_Change(ByVal Target As Range)
Dim contactName As String
Dim contacts As Object
Dim contact As Object
Dim comment As Excel.comment
Dim contactInfo As String
Dim addressLists As Object ' Outlook.AddressLists
Dim GAL As Object ' Outlook.AddressList
Dim addressEntries As Object ' Outlook.AddressEntries
Dim addressEntry As Object ' Outlook.AddressEntry
' get target cell value ONLY if single cell selected
If Target.Cells.Count = 1 Then
contactName = Target.Value
Else
Exit Sub
End If
' ignore blanks
If Len(contactName) = 0 Then
Exit Sub
End If
' grab Outlook, if not already instantiated previously
If Outlook Is Nothing Then
Set Outlook = GetOutlookApp
End If
' get contacts
Set contacts = GetItems(GetNS(Outlook), olFolderContacts)
' try to grab target contact
On Error Resume Next
Set contact = contacts.Item(contactName)
On Error GoTo 0
' remove existing comment, if any
On Error Resume Next
Set comment = Target.comment
comment.Delete
On Error GoTo 0
If contact Is Nothing Then
' try to find in GAL
Set addressLists = GetNS(Outlook).addressLists
Set GAL = addressLists.Item("Global Address List")
Set addressEntries = GAL.addressEntries
On Error Resume Next
Set addressEntry = addressEntries.Item(Target.Value)
On Error GoTo 0
If addressEntry Is Nothing Then
' nothing in Contacts Folder or GAL
contactInfo = "No contact found with this name."
Else
' in GAL but not Contacts Folder
contactInfo = addressEntry.Name & Chr(10) & addressEntry.Address & Chr(10) & _
Chr(10) & "This information came from the Global Address List."
End If
Else
' in Contacts Folder
contactInfo = contact.Email1Address
End If
' put contact info into adjacent cell
' turn off Events to avoid event firing again
Application.EnableEvents = False
Target.Offset(0, 1).Value = contactInfo
Application.EnableEvents = True
End Sub
Function GetOutlookApp() As Object
Set GetOutlookApp = CreateObject("Outlook.Application")
End Function
Function GetNS(ByRef app As Object) As Object
Set GetNS = app.GetNamespace("MAPI")
End Function
Function GetItems(olNS As Object, folder As Long) As Object
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
Comment