' (Verweis hinzufügen: Microsoft Outlook 11.0 Object Library)
' (Treeview hinzufügen: tvwOutlook)
Option Explicit
 
 
Private mbFormLoad  As Boolean
Private moOutlook   As Outlook.Application
Private moNameSpace As Outlook.NameSpace
Private moInbox     As Outlook.MAPIFolder
 
 
 
'----------------------------------------------------------------------------
' Form_Activate
'----------------------------------------------------------------------------
Private Sub Form_Activate()
 
  If mbFormLoad Then
    Screen.MousePointer = vbHourglass
 
    Call ReadOutlookFolders
    mbFormLoad = False
 
    Screen.MousePointer = vbDefault
  End If
 
End Sub
 
 
'----------------------------------------------------------------------------
' Form_Load
'----------------------------------------------------------------------------
Private Sub Form_Load()
 
  Screen.MousePointer = vbHourglass
 
  mbFormLoad = True
  tvwOutlook.Visible = False
 
  ' Objekte Initialisieren
  Set moOutlook = New Outlook.Application
  Set moNameSpace = moOutlook.GetNamespace("MAPI")
 
  Screen.MousePointer = vbDefault
 
End Sub
 
 
 
'----------------------------------------------------------------------------
' ReadOutlookFolders
'----------------------------------------------------------------------------
Private Sub ReadOutlookFolders()
Dim i       As Integer
Dim sKey    As String
 
  tvwOutlook.Visible = False
  tvwOutlook.Nodes.Clear
 
  'Reference the default Contacts folder.
  Set moInbox = moNameSpace.GetDefaultFolder(olFolderInbox)
 
  With moInbox
    sKey = .Name & ";" & .Name & ";" & .EntryID & ";" & .Items.Count
    Call tvwOutlook.Nodes.Add(, , sKey, .Name & " (" & .Items.Count & ")")
    tvwOutlook.Nodes.Item(tvwOutlook.Nodes.Count).EnsureVisible
 
    With .Folders
      For i = 1 To .Count
        Call FillTreeView(.Item(i), sKey)
        DoEvents
      Next i
    End With
  End With
  tvwOutlook.Nodes.Item(1).EnsureVisible
 
  Set moInbox = Nothing
  tvwOutlook.Visible = True
 
End Sub
 
 
 
'----------------------------------------------------------------------------
' FillTreeView
'----------------------------------------------------------------------------
Private Sub FillTreeView(ByVal oFolder As Outlook.MAPIFolder, ByVal sRelative _
  As String)
Dim i       As Integer
Dim sKey    As String
 
  With oFolder
    sKey = ExtractString(sRelative, ";", 1) & "\" & .Name & ";" & .Name & ";" & _
      .EntryID & ";" & .Items.Count
 
    Call tvwOutlook.Nodes.Add(sRelative, tvwChild, sKey, .Name & IIf( _
      .Items.Count > 0, " (" & .Items.Count & ")", ""))
    tvwOutlook.Nodes.Item(tvwOutlook.Nodes.Count).EnsureVisible
 
    sRelative = sKey
    For i = 1 To .Folders.Count
      If .Folders.Count > 0 Then
        Call FillTreeView(.Folders.Item(i), sRelative)
        DoEvents
      End If
    Next i
  End With
 
End Sub
 
 
'----------------------------------------------------------------------------
' ExtractString
'----------------------------------------------------------------------------
Public Function ExtractString(sString As String, sDelimiter As String, iNo As _
  Integer) As String
Dim i         As Integer
Dim lStart    As Long
Dim lEnd      As Long
 
  On Error GoTo FAULT
 
  lStart = 1
 
  ' Beginn des Teilstrings bestimmen
  For i = 2 To iNo
    lStart = InStr(lStart, sString, sDelimiter)
    If lStart = 0 Then Exit For
    lStart = lStart + Len(sDelimiter)
  Next i
 
  ' Ende des Teilstrings bestimmen
  If lStart Then
    lEnd = InStr(lStart, sString, sDelimiter)
    If lEnd = 0 Then lEnd = Len(sString) + 1
    ExtractString = Mid(sString, lStart, lEnd - lStart)
  End If
  Exit Function
 
FAULT:
  Call Err.Raise(Err.Number, , "ExtractString: " & Err.Description & "; iNo = " _
    & iNo)
 
End Function