Public Class DirDialogClass
 
  Public Structure BrowseInfo
    Dim hWndOwner As Long
    Dim pIDLRoot As Long
    Dim pszDisplayName As Long
    Dim lpszTitle As Long
    Dim ulFlags As Long
    Dim lpfnCallback As Long
    Dim lParam As Long
    Dim iImage As Long
  End Structure
 
  Declare Function SHBrowseForFolder Lib "shell32" (ByVal lpbi As BrowseInfo) _
    As Long
  Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
  ByVal lpBuffer As String) As Long
  Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As _
  String, ByVal lpString2 As String) As Long 'Verknüpfen von nullterminierten 
  ' Strings
 
  Public Const CSIDL_DRIVES = &H11&
 
  'FolderID:
  Public Const SF_ShowComputer As Long = 0 'Zeigt den gesamten Inhalt des 
  ' Computers an. (Standard)
  Public Const SF_ShowProgramme As Long = 2 'Zeigt den Ordner Programme im 
  ' Startmenü an.
  Public Const SF_ShowMyFolder As Long = 5 'Zeigt den Ordner Eigene Dateien an.
  Public Const SF_ShowFavoriten As Long = 6 'Zeigt den Ordner Favoriten an.
  Public Const SF_ShowAutostart As Long = 7 'Zeigt den Autostart-Ordner an.
  Public Const SF_ShowDokumente As Long = 8 'Zeigt den Dokumenten-Ordner an.
  Public Const SF_ShowSendTo As Long = 9 'Zeigt den SendTo-Ordner an.
  Public Const SF_ShowStartmenü As Long = 11 'Zeigt das Startmenüs an.
  Public Const SF_ShowMyMusik As Long = 13 'Zeigt den Ordner Eigene Musik an.
  Public Const SF_ShowMyVideos As Long = 14 'Zeigt den Ordner Eigene Videos an.
  Public Const SF_ShowDesktop As Long = 16 'Zeigt den Inhalt des Desktops an.
  Public Const SF_ShowLaufwerke As Long = 17 'Zeigt die Laufwerke des Computers 
  ' an.
  Public Const SF_ShowMyNet As Long = 18 'Zeigt den Inhalt der Netzwerkumgebung 
  ' an.
  Public Const SF_ShowFonts As Long = 20 'Zeigt den Ordner Fonts (Schriftarten) 
  ' an.
  Public Const SF_ShowAnwedungsdaten As Long = 26 'Zeigt den Ordner 
  ' Anwendungsdaten an. (Dateien lassen sich nicht anzeigen!)
 
  'Flags:
  Public Const SF_BrowseForComputer As Long = &H1000 'Nur Computer als Auswahl 
  ' erlauben.
  Public Const SF_BrowseForPrinter As Long = &H2000  'Nur Drucker als Auswahl 
  ' erlauben.
  Public Const SF_BrowseForFiles As Long = &H4000 + &H1 'Der Dialog zeigt neben 
  ' den Ordnern auch Dateien.
  Public Const SF_DONTGOBELOWDOMAIN As Long = &H2  'Der Dialog zeigt keine 
  ' Netzwerkordner unterhalb der aktuellen Domain.
  Public Const SF_RETURNFSANCESTORS As Long = &H8  'Nur Dateisystemobjekte als 
  ' Auswahl erlauben.
  Public Const SF_RETURNONLYFSDIRS As Long = &H1  'Nur Dateisystemordner als 
  ' Auswahl erlauben.
  Public Const SF_STATUSTEXT As Long = &H4  'Der Dialog enthält eine 
  ' Statuszeile. Die Rückruffunktion kann die Statuszeile ausfüllen.
 
  'Zeigt den Dialog an. Wenn Abbrechen gedrückt wurde
  'wird ein leerer String-Wert zurückgegeben
  Function SelectFolder(ByVal Owner As Form, Optional ByVal Prompt As String = _
    "Bitte geben Sie ein Verzeichnis an.", Optional ByVal FolderID As Long = _
    SF_ShowComputer, Optional ByVal Flags As Long = SF_RETURNONLYFSDIRS) As _
    String
    Dim BInfo As BrowseInfo
    Dim DlgTitle As String
    Dim pid As Long
    Dim SelPath As String
    Dim Dummy As Boolean
 
    'Prüfe FolderID:
    Dummy = False
    Select Case FolderID
      Case 0, 2, 5, 6, 7, 8, 9, 11, 13, 14, 16, 17, 18, 20, 26 '<- Nur diese 
      ' Werte werden zugelassen!
        Dummy = True
    End Select
    If Dummy = False Then
      'MsgBox "Falscher Wert der FolderID!", vbCritical
      'Exit Function
    End If
 
    With BInfo
      .hWndOwner = Owner.Handle.ToInt32
      .pIDLRoot = FolderID
      .lpszTitle = lstrcat(Prompt, "") 'Titel des Dialoges
      If Flags = 0 Then .ulFlags = 1 Else .ulFlags = Flags 'Nur 
      ' Dateisystemordner erlaubt
    End With
 
    pid = SHBrowseForFolder(BInfo) '<--------------- HIER TRITT DER FEHLER AUF 
    ' ----------
 
    If pid Then
      SelPath = Space(255)
      Call SHGetPathFromIDList(pid, SelPath)
      SelPath = Left(SelPath, InStr(SelPath, Chr(0)) - 1)
    Else
      SelPath = ""
    End If
    SelectFolder = SelPath
  End Function
 
End Class