Hi
You can use this macro in Excel (you can assign it to a button in the ribbon). Just select the names and you get the name, email, department, telephone number form the GAL.
Option Explicit
Sub GetOutlookInfo()
'you can add a button in the ribbon and assign this macro to it
On Error Resume Next
Dim I As Integer
Dim ToAddr As String
Dim ActivePersonVerified As Boolean
Dim ol As Outlook.Application
Dim DummyEMail As MailItem
Dim ActivePersonRecipient As Recipient
Dim oAE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser
Dim oPA As Outlook.PropertyAccessor
Dim AliasRange As Range
Dim RowsInRange As Integer
Dim intAreas As Integer
Dim shtCurrentSheet As String
'check whether the selection is contiguous or not. if not, exit sub
intAreas = Selection.Areas.Count
If intAreas > 1 Then
MsgBox "Please select a contiguous area, you curently selected " & intAreas & " areas. You can have multiple cells in a single area."
Exit Sub
End If
'create a new sheet and copy the selection there
shtCurrentSheet = ActiveSheet.Name
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = tmpSheet 'random name, see function below
'add column names
Cells(1, 1) = "email or Name"
Cells(1, 2) = "Name"
Cells(1, 3) = "email address"
Cells(1, 4) = "Department"
Cells(1, 5) = "Job Title"
Cells(1, 6) = "Office Location"
Cells(1, 7) = "Company"
Cells(1, 8) = "Telephone"
Range("A1:H1").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
'copy the names into the new sheet
Sheets(shtCurrentSheet).Activate
Selection.Copy
Sheets(Sheets.Count).Activate
Range("A2").Select
ActiveSheet.Paste
'Instantiate Outlook code taken from:
'http://social.msdn.microsoft.com/Forums/office/en-US/183a9b77-7f5a-4afc-91e6-fbe2914c5f78/extract-data-from-the-global-address-book-with-vba?forum=outlookdev
'Instantiate Outlook
Set ol = CreateObject("Outlook.Application")
'E-mail aliases are in a named range "aliasrange"
'Assign the named range to a range object
'Set AliasRange = Range("aliasrange")
Set AliasRange = Selection
'Create a dummy e-mail to add aliases to
Set DummyEMail = ol.CreateItem(olMailItem)
RowsInRange = AliasRange.Rows.Count
'Loop through the aliases to retrieve the Exchange data
For I = 1 To RowsInRange
'Assign the current alias to a variable ToAddr
ToAddr = AliasRange.Cells(I, 1)
'Use the alias to create a recipient object and add it to the dummy e-mail
Set ActivePersonRecipient = DummyEMail.Recipients.Add(ToAddr)
ActivePersonRecipient.Type = olTo
'Resolve the recipient to ensure it is valid
ActivePersonVerified = ActivePersonRecipient.Resolve
'If valid, use the AddressEntry property of the recipient to return an AddressEntry object
If ActivePersonVerified Then
Set oAE = ActivePersonRecipient.AddressEntry
'Use the GetExchangeUser method of the AddressEntry object to retrieve the ExchangeUser object for the recipient.
Set oExUser = oAE.GetExchangeUser
'Write the properties of the ExchangeUser object to adjacent columns on the worksheet.
AliasRange.Cells(I, 1).Offset(0, 1).Value = oExUser.Name
AliasRange.Cells(I, 2).Offset(0, 1).Value = oExUser.PrimarySmtpAddress
AliasRange.Cells(I, 3).Offset(0, 1).Value = oExUser.Department
AliasRange.Cells(I, 4).Offset(0, 1).Value = oExUser.JobTitle
AliasRange.Cells(I, 5).Offset(0, 1).Value = oExUser.City
AliasRange.Cells(I, 6).Offset(0, 1).Value = oExUser.CompanyName
AliasRange.Cells(I, 7).Offset(0, 1).Value = oExUser.BusinessTelephoneNumber
End If
'Remove the recipient from the e-mail
ActivePersonRecipient.Delete
Next I
ExitOutlookEmail:
Set DummyEMail = Nothing
Set ol = Nothing
'autofit columns
Columns("A:H").EntireColumn.AutoFit
Range("A1").Select
End Sub
Function tmpSheet() As String
Dim sLetter(8) As String, sName As String
Dim iLetterType As Integer
Dim I As Integer
sName = ""
For I = 0 To 7
iLetterType = WorksheetFunction.RandBetween(1, 3)
Select Case iLetterType
Case 1
sLetter(I) = Chr(WorksheetFunction.RandBetween(65, 90))
Case 2
sLetter(I) = Chr(WorksheetFunction.RandBetween(97, 122))
Case 3
sLetter(I) = Chr(WorksheetFunction.RandBetween(48, 57))
End Select
sName = sName & sLetter(I)
Next
tmpSheet = sName
End Function
Bookmarks