Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olAddrList As Outlook.AddressList
Dim olAddrEntry As Outlook.AddressEntry
 
Private Sub Form_Load()
 
Dim nodx As Node
Dim g As Long
 
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olAddrList = olNS.AddressLists("Globales Adressbuch")
 
    trvbaum.ImageList = ImageList1
 
    j = 1
 
        For g = 1 To olAddrList.AddressEntries.Count
            Set olAddrEntry = olAddrList.AddressEntries(g)
            If TypeName(olAddrEntry.Members) <> "Nothing" Then
                Set nodx = trvbaum.Nodes.Add(, , "Z" & g, _
                  olAddrList.AddressEntries(g), 1) 'Neuen Knoten Hinzufügen
            End If
 
        Next g
 
Exit Sub
 
errorhandler:
 
    MsgBox "Es ist ein Fehler aufgetreten" & vbCrLf & _
           "Fehlernummer: " & Err.Number & vbCrLf & _
           "Fehlerbeschreibung: " & Err.Description
 
 
End Sub
 
Sub FügeUnterpunkteEin(OberGruppe As String, g As String)
 
Dim strSQL As String
Dim nodx As Node
Dim oladdrcheck As Outlook.AddressEntry
 
        On Error GoTo errorhandler
 
        If TypeName(olAddrEntry.Members) <> "Nothing" Then
 
            For Each memberentry In olAddrEntry.Members
 
                If memberentry <> "" Then
 
                    Set oladdrcheck = olAddrList.AddressEntries(CStr( _
                      memberentry))
 
                    'Falls der einzufügende Unterpunkt weitere Unterpunkte 
                    ' besitzt,
                    'Soll er nicht eingefügt werden
                    If TypeName(oladdrcheck.Members) = "Nothing" Then
                        j = j + 1
                        Set nodx = trvbaum.Nodes.Add(g, tvwChild, "H" & j, _
                          memberentry, 1, 1)
 
                    End If
 
                End If
 
            Next
 
        End If
 
    Exit Sub
 
errorhandler:
 
    MsgBox "Es ist ein Fehler aufgetreten." & vbCrLf & _
           "Fehlernummer: " & Err.Number & vbCrLf & _
           "Fehlerbeschreibung: " & Err.Description, vbCritical, "Fehler"
 
End Sub
 
 
Private Sub trvbaum_Click()
 
    Set olAddrEntry = olAddrList.AddressEntries(trvbaum.SelectedItem.Text)
 
    If trvbaum.SelectedItem.Children <= 0 Then
        FügeUnterpunkteEin trvbaum.SelectedItem.Text, trvbaum.SelectedItem.Key
    End If
 
 
End Sub

und noch sch?ne Gr??e von mir