Ein Verzeichnis auswählen

Häufig benötigt man nur ein bestimmtes Verzeichnis, das dann weiterverwendet werden soll. Leider wird dazu kein integriertes Dialogfenster angeboten, so dass man evtl. über die Dateiauswahl gehen muss. Dieses hat aber den großen Nachteil, dass aus dem vollständigen Dateinamen (inkl. Pfad) erst noch der Dateipfad ermittelt werden muss.

Schneller und bequemer geht es mit zwei APIs, mit denen direkt ein beliebiges Verzeichnis ausgewählt werden kann.
Standardmäßig beginnt die Verzeichnisauswahl auf oberster Ebene, aber über die Angabe eines Startverzeichnisses im Funktionsaufruf, kann die Auswahl direkt in einem Verzeichnis beginnen.

Die Funktion GetFolderInternal() erwartet als Aufrufparameter einen Beschritungstext und ein Standardverzeichnis, als Rückgabewert wird der Name des ausgewählten Verzeichnisses zurückgeliefert.

Dieser Funktion lässt sich erst ab Word2000 das Anfangsverzeichnis mitgeben, da die verwendete Callback-Funktion unter Word97 nicht unterstützt wird.

Public Function GetFolderInternal(ByVal Caption As String, _
    ByVal Default As String) As String

Um beim nächsten Aufruf dieses Dialogfensters wieder im letzten Verzeichnis zu beginnen, genügt es für das Standardverzeichnis das zuletzt ausgewählte Verzeichnis anzugeben:

  Option Explicit 
   Private Type BROWSEINFO
      hWndOwner As Long 
      pidlRoot As Long 
      pszDisplayName As String 
      lpszTitle As String 
      ulFlags As Long 
      lpFn As Long 
      lParam As String 
      iImage As Long 
   End Type 
   Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (ByRef lpbi As BROWSEINFO) As Long 
   Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
    ByVal pszPath As String) As Long 
   Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
   Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long 
   Private Const WM_USER As Long = &H400
   Private Const BIF_RETURNONLYFSDIRS As Long = 1
   Private Const BFFM_INITIALIZED As Long = 1
   Private Const BFFM_SETSELECTION As Long = (WM_USER + 102)
   Private Const MAX_PATH As Long = 260

Public Function GetFolderInternal(ByVal Caption As String, _
    ByVal Default As String) As String 
      Dim BI As BROWSEINFO
      Dim ListIdx As Long 
      Dim Path As String 
      With BI
         .lpszTitle = Caption
         .ulFlags = BIF_RETURNONLYFSDIRS
         .lpFn = MakeFktnPtr(AddressOf BrowseCallbackProc)
         .lParam = Default
      End With 
      Path = String$(MAX_PATH + 1, vbNullChar)
      ListIdx = SHBrowseForFolder(BI)
      If SHGetPathFromIDList(ListIdx, Path) Then 
         GetFolderInternal = Left$(Path, InStr(Path, vbNullChar) - 1)
      End If 
      CoTaskMemFree ListIdx
End Function 

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal Msg As Long, _
    ByVal lParam As Long, ByVal lpData As Long) As Long 
      On Error Resume Next 
      If Msg = BFFM_INITIALIZED Then 
         SendMessage hWnd, BFFM_SETSELECTION, 1&, lpData
      End If 
   End Function 

Private Function MakeFktnPtr(ByVal FktnPtr As Long) As Long 
      MakeFktnPtr = FktnPtr
End Function