Zur Auswahl eines Ordners ist der von VB zur Verfügung gestellte CommonDialog nicht in der Lage, er kann nur Dateien zur Auswahl anbieten. Für die Auswahl eines Ordners hält Windows die API-Funktion SHBrowseForFolder() in der Bibliothel Shell32.dll bereit. Dessen Handhabung wird in folgendem Code demonstriert.

Beachten Sie bitte folgende Besonderheiten:

1. Es wird sichergestellt, daß kein uninialisierter String (Null-Pointer) als Default-Pfad ans API übergeben wird, sonst Schutzverletzung! (Zeile: If StrPtr(DefaultPath) = 0 Then DefaultPath = ""; siehe hierzu auch den Artikel Leerer String vs. vbNullString).
2. Es wird sichergestellt, daß kein ungültiger Pfad wie "Arbeitsplatz" ausgewählt werden kann (Zeile mit BFFM_ENABLEOK)
3. Der Dialog wird auf dem Bildschirm zentriert dargestellt.

Fügen Sie folgenden Code in ein Standard-Modul ein:

Option Explicit

'API-Deklarationen

  Private Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As Long
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As String
    iImage As Long
  End Type

  Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
  End Type

Private Declare Function CoTaskMemFree Lib "ole32.dll" _
  (ByVal hMem As Long) As Long
Private Declare Function GetWindowRect Lib "user32" _
  (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SendMessageByVal Lib "user32" Alias "SendMessageA" _
  (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" _
  (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
  ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" _
  (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private Const BIF_RETURNONLYFSDIRS& = 1&
Private Const MAX_PATH As Long = 260&
Private t As String
            

Public Function GetFolderByDialog(ByVal DialogParent As Form, ByVal DefaultPath As String, _
  ByVal Title As String, ByVal Prompt As String) As String

Dim bi As BROWSEINFO, IDList As Long, PathName As String, l As Long
If StrPtr(DefaultPath) = 0 Then DefaultPath = ""
t = Title
  With bi
  .hwndOwner = DialogParent.hwnd
  .pidlRoot = 0&
  .lpszTitle = Prompt
  .ulFlags = BIF_RETURNONLYFSDIRS
  .lpfn = GetProcAdress(AddressOf BrowseCallbackProc)
  .lParam = DefaultPath
  End With
IDList = SHBrowseForFolder(bi) ' Dialogbox anzeigen
  If IDList <> 0 Then          ' Pfadname aus ID-Liste holen
  PathName = Space$(MAX_PATH)
  l = SHGetPathFromIDList(IDList, PathName)
  l = CoTaskMemFree(IDList)    ' Platz für ID-Liste freigeben
  PathName = Mid$(PathName, 1, InStr(PathName, vbNullChar) - 1)
  End If
GetFolderByDialog = PathName
End Function
            

Private Function BrowseCallbackProc(ByVal hnd As Long, ByVal uMsg As Long, _
  ByVal lParam As Long, ByVal lpData As Long) As Long
'Callback-Routine für SHBrowseForFolder()

Const WM_USER& = &H400
Const SWP_NOSIZE& = 1
Const SWP_NOZORDER& = 4
Const BFFM_INITIALIZED& = 1
Const BFFM_SELCHANGED& = 2
Const BFFM_SETSTATUSTEXT& = 12
Const BFFM_ENABLEOK& = (WM_USER + 101)
Const BFFM_SETSELECTION& = (WM_USER + 102)

Dim l As Long, s As String, r As RECT, x As Long, y As Long

  Select Case uMsg
  Case BFFM_INITIALIZED:
    l = SendMessageByVal(hnd, BFFM_SETSTATUSTEXT, 0&, t)
    l = SendMessageByVal(hnd, BFFM_SETSELECTION, 1&, lpData)
    l = GetWindowRect(hnd, r)
      With r
      x = (Screen.Width \ Screen.TwipsPerPixelX - .Right + .Left) \ 2
      y = (Screen.Height \ Screen.TwipsPerPixelY - .Bottom + .Top) \ 2
      End With
    l = SetWindowPos(hnd, 0&, x, y, 0&, 0&, SWP_NOSIZE Or SWP_NOZORDER)
  Case BFFM_SELCHANGED
    s = Space$(MAX_PATH)
    l = SHGetPathFromIDList(lParam, s)
    l = SendMessageByVal(hnd, BFFM_ENABLEOK, 0&, InStr(s, vbNullChar) - 1)
  End Select
End Function
            

Public Function GetProcAdress(ByVal l As Long) As Long
' Hilfsroutine; erforderlich, da der AddressOf-Operator nur in Funktionsaufrufen
' zulässig ist, wir müssen den Wert aber einer Strukturvariablen zuweisen
GetProcAdress = l
End Function
            

Beispiel zum Aufruf (in einem Form-Modul):

Dim s As String
s = GetFolderByDialog(Me, "C:\", "Verzeichnisauswahl", "Wählen Sie ein Verzeichnis aus:")
  If StrPtr(s) Then
  ' Benutzerauswahl verarbeiten
  Else
  ' Vorgang vom Benutzer abgebrochen
  End If
            

Dieser Aufruf erzeugt folgenden Dialog: