*****************Start Klasse************************
Private Type BrowseInfo
    HWndOwner As Long       'Das Handle des "Besitzer"-Fensters, also des _
      Fensters, von dem aus der Verzeichnisdialog aufgerufen wird.
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long       'Diese Variable enthält die Beschriftung des 
    ' Dialogs, die in der Titelleiste des Dialogfensters angezeigt wird.
    ulFlags As Long         'Diese Variable beeinflusst die Verhaltensweise des 
    ' Dialogs.
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
 
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) _
  As Long
 
Public Enum uFlag
    BIF_BROWSE_FOR_COMPUTER = &H1000    'Als Auswahl sind nur Computer erlaubt. 
    ' Wenn der Anwender andere Objekte, also Ordner oder Laufwerke markiert, 
    ' kann der OK-Button nicht ausgewählt werden.
    BIF_BROWSE_FOR_PRINTER = &H2000     'Gestattet nur Drucker als Auswahl.
    BIF_BROWSE_INCLUDE_FILES = &H4000   'Der Dialog zeigt neben Computern, 
    ' Laufwerken und Ordnern auch Dateien an.
    BIF_RETUR_NONLY_FSDIRS = &H1        'Gestattet nur Dateisystemordner als 
    ' Auswahl.
    BIF_DONT_GOBELOW_DOMAIN = &H2       'Der Dialog zeigt keine Netzwerkordner 
    ' unterhalb der aktuellen Domain.
    BIF_STATUSTEXT = &H4                'Der Dialog enthält eine Statuszeile. 
    ' Die Rückruffunktion kann die Statuszeile ausfüllen.
    BIF_RETUR_NFSANCE_STORS = &H8       'Gestattet nur Dateisystemobjekte als 
    ' Auswahl.
End Enum
 
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As _
  Long, ByVal lpBuffer As String) As Long
 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal _
  lpString1 As String, ByVal lpString2 As String) As Long
 
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (pv As Any)
 
Private Const MAX_PATH = 260
 
Public Function Show(ByRef hwnd As Long, ByVal windowTitel As String, ByVal _
  uFlags As uFlag, ByRef selectedFolder As String) As Boolean
 
On Error GoTo fehler:
 
    Dim n As Integer
    Dim IDList As Long
    Dim Result As Long
    Dim ThePath As String
    Dim BI As BrowseInfo
 
    'Erzeugen der Datenstruktur
    With BI
        .HWndOwner = hwnd
        .lpszTitle = lstrcat(windowTitel, "")
        'Nur Dateisystemordner erlaubt
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
 
    IDList = SHBrowseForFolder(BI)
 
    'Wenn IDList > 0, dann Auswahl bearbeiten
    If IDList > 0 Then
 
        'Speicher anfordern
        ThePath = String$(MAX_PATH, 0)
        'IID-Liste in Pfadangabe konvertieren
        Result = SHGetPathFromIDList(IDList, ThePath)
 
        'Speicher für IID-Liste verwerfen
        Call CoTaskMemFree(IDList)
 
        'Alle Bytes hinter Nullbyte verwerfen
        n = InStr(ThePath, vbNullChar)
        If n Then selectedFolder = Left$(ThePath, n - 1)
 
        selectedFolder = selectedFolder & IIf(Right(selectedFolder, 1) <> "\", _
          "\", "")
 
        Show = True
 
    Else
 
        Show = False
 
    End If
 
Exit Function
 
fehler:
 
    Show = False
    Exit Function
 
End Function
 
*****************end Klasse************************
 
*****************Start aufruf Klasse************************
 
dim fd as new folderdialog,path$
 
if  fd.show(me.hwnd,"Bitte Ordner wählen",0&,path) then msgbox path
 
*****************End aufruf Klasse************************