by Joost Rongen (4 Submissions)
Category: Microsoft Office Apps/VBA
Compatability: Visual Basic 3.0
Difficulty: Intermediate
Date Added: Wed 3rd February 2021
Rating: 
(7 Votes)
This peace of code shows you how to obtain all the contacts as been stored in your Outlook pst-file. No matter how mutch contact-folders you have and how deep the three might be. (tested with Outlook 2000)
VBcodersPrivate objApp As Outlook.Application
Private objNS As Outlook.NameSpace
Private objFolder As Outlook.MAPIFolder
Private objItem As Outlook.ContactItem
Private colAdressFolders As Collection
Sub Main()
Dim lngLoop As Long
Set objApp = New Outlook.Application
Set objNS = objApp.GetNamespace("MAPI")
Set colAdressFolders = New Collection
Set objFolder = objNS.Folders.GetFirst ' get root-folder
' recursive loop thrue all folders to collect the references to Adressbooks
For lngLoop = 1 To objFolder.Folders.Count
If objFolder.Folders.Item(lngLoop).DefaultItemType = olContactItem Then
RecursiveSearch objFolder.Folders.Item(lngLoop), colAdressFolders
End If
Next lngLoop
' open every contact-folder and loop all entries
For Each objFolder In colAdressFolders
For lngLoop = 1 To objFolder.Items.Count
Set objItem = objFolder.Items(lngLoop)
Debug.Print objFolder.Name, objItem.FileAs
Next lngLoop
Next
End Sub
Private Sub RecursiveSearch(objSubFolder As Outlook.MAPIFolder, colAdrFolders As Collection)
On Error GoTo Errorhandler
Dim lngLoop As Long
' check for entries in this subfolder
If objSubFolder.Items.Count > 0 Then
'add reference to collection
colAdrFolders.Add objSubFolder
End If
' check for subfolders
If objSubFolder.Folders.Count > 0 Then
For lngLoop = 1 To objSubFolder.Folders.Count
RecursiveSearch objSubFolder.Folders.Item(lngLoop), colAdrFolders
Next lngLoop
End If
Exit Sub
Errorhandler:
MsgBox "An unexpected error occured methode RECURSIVESEARCH", vbCritical + vbOKOnly, "Problem"
Err.Clear
End Sub
