Dim objNS As Outlook.NameSpace
        Dim objMF As Outlook.MAPIFolder
        Dim objAL As Outlook.Folders
        Dim objIt As Outlook.Items
        Dim zaehler As Integer
 
        objOutlook = GetObject(, "Outlook.Application")
 
        objNS = objOutlook.GetNamespace("MAPI")
 
        objAL = objNS.Folders
        Call showfolders(objAL)
 
        objIt = Nothing
        objAL = Nothing
        objMF = Nothing
        objNS = Nothing
        objOutlook = Nothing
 
---------------------------
 
    Private Function showfolders(ByRef objAL As Outlook.Folders)
        Dim zaehler As Integer
        Dim objFd As Outlook.Folders
 
        For zaehler = 1 To objAL.Count
            If objAL.Item(zaehler).DefaultItemType = _
              Outlook.OlItemType.olContactItem Then
                MsgBox(objAL.Item(zaehler).Name)
 
            End If
 
            If objAL.Item(zaehler).Folders.Count > 0 Then
                Call showfolders(objAL.Item(zaehler).Folders)
            End If
        Next zaehler
    End Function

Sub ShowAsAddressBookChange()
 
Dim olApp 'As Outlook.Application
Dim nmsName 'As Outlook.Namespace 
Dim fldFolder 'As Outlook.MAPIFolder 
 
Set olApp = CreateObject("Outlook.Application") 
'Create instance of namespace 
Set nmsName = olApp.GetNamespace("MAPI") 
nmsName.Logon 
'get Contacts 
Set fldFolder = nmsName.GetDefaultFolder(10) 
 
'Display the folder as Outlook Address Book 
fldFolder.ShowAsOutlookAB = True
 
End Sub