accessing Outlook Address book from Excel VBA

[Stefi]

Hi All,

I'd like to retrieve some data (name, department, e-mail address) of members
of a group from Outlook Address book from Excel VBA. Please, help me how to
do it!

Thanks,
Stefi

 

[Norman Jones]

Hi Steffi,

Add a reference to the Outlook library:

Alt-F11 to open the VBE,

Menu | Tools | References |
Find and check: Microsoft Outlook xx Object Library
(xx is the version number.)

Insert a Userfom with a ListBox and
a CommandButton; in the Userform
module post the following code:

'=============>>
Private Sub UserForm_Initialize()
Dim olApp As Outlook.Application
Dim oContact As Outlook.ContactItem
Dim oContactFolder As Outlook.MAPIFolder
Dim oContactItems As Outlook.Items
Dim oNS As Outlook.Namespace
Dim i As Long
Dim j As Long
Dim arr()

With Me.ListBox1
.ColumnCount = 3
.ColumnWidths = "90 pt;72 pt;90 pt"
.TextColumn = -1
End With

On Error GoTo XIT
Set olApp = New Outlook.Application
Set oNS = olApp.GetNamespace("MAPI")
Set oContactFolder = oNS.GetDefaultFolder(olFolderContacts)
Set oContactItems = oContactFolder.Items

With Me
For i = 1 To oContactItems.Count
If oContactItems.Item(i).Class = olContact Then
Set oContact = oContactItems.Item(i)
j = j + 1
ReDim Preserve arr(0 To 2, 1 To j)
With oContact
arr(0, j) = .FullName
arr(1, j) = .HomeAddress
arr(2, j) = .HomeTelephoneNumber
End With
End If
Next i
Me.ListBox1.List() = Application.Transpose(arr)
End With

XIT:
Set oContact = Nothing
Set oContactItems = Nothing
Set oContactFolder = Nothing
Set oNS = Nothing
Set olApp = Nothing
End Sub

'----------------->>
Private Sub CommandButton1_Click()
Dim SH As Worksheet
Dim destRng As Range

Set SH = ThisWorkbook.Sheets("Sheet1") '<<=== CHANGE

Set destRng = SH.Range("A" & Rows.Count).End(xlUp)(2)
With Me.ListBox1
destRng.Value = .List(.ListIndex, 0)
destRng(1, 2).Value = .List(.ListIndex, 1)
destRng(1, 2).Value = .List(.ListIndex, 2)
End With
End Sub
'<<=============

 

[Stefi]

Thanks, Norman, I'm going to give it a try and let you know the result later!
Stefi


„Norman Jones†ezt írta:

 

[Stefi]

Hi Norman,

Your code works, but I have still a problem:

Set oContactFolder = oNS.GetDefaultFolder(olFolderContacts)
returns my personal Address book, but I need a group and its members from
the company's global Address book. I can't find out how to identify and
access it.

Please help!

Regards,
Stefi


„Stefi†ezt írta:

 

[Norman Jones]

Hi Stefi,

Using Outlook methods, I do not believe
that you interrogate the Global Address
book (GAL) to obtain the department
details.

To return the name and email details, in
the Userform module, try something like:

'=============>>
Option Explicit
Dim arr() As String

Private Sub UserForm_Initialize()
Dim olApp As Outlook.Application
Dim oNS As Outlook.Namespace

Dim oAL As AddressList
Dim oAE As AddressEntry
Dim i As Long
Dim j As Long

With Me.ListBox1
.ColumnCount = 3
.ColumnWidths = "90 pt;72 pt;90 pt"
.TextColumn = -1
End With

On Error GoTo XIT
Set olApp = New Outlook.Application
Set oNS = olApp.GetNamespace("MAPI")
Set oAL = oNS.AddressLists(1)

With Me
For i = 1 To oAL.AddressEntries.Count
Set oAE = oAL.AddressEntries.Item(i)
j = j + 1
ReDim Preserve arr(1 To 3, 1 To j)
With oAE
arr(1, j) = .Name
arr(2, j) = .Address
arr(3, j) = .GetContact
End With
Next i
Me.ListBox1.List() = Application.Transpose(arr)
End With

XIT:
Set oAE = Nothing
Set oAL = Nothing
Set oNS = Nothing
Set olApp = Nothing
End Sub

'----------------->>
Private Sub CommandButton1_Click()
Dim SH As Worksheet
Dim destRng As Range

Set SH = ThisWorkbook.Sheets("Foglio1") '<<=== CHANGE

Set destRng = SH.Range("A" & Rows.Count).End(xlUp)(2)
destRng.Resize(UBound(arr, 2), 2).Value = _
Application.Transpose(arr) 'arr2
End Sub
'<<=============

In order to interrogate the GAL further, see
the techniques used by Pavel Nagaev at:

Import Active Directory user data into Outlook address books
http://www.outlookexchange.com/articles/Pavelnagaev/nagaev_c1p4.asp

 

[Stefi]

Thanks Norman for your guidance, it'll be a nice job to follow it!
Regards,
Stefi


„Norman Jones†ezt írta: