Ein beliebiges Verzeichnis öffnen

Mit den integrierten Dialog-Fenstern (Dialogs(...) lassen sich bequem Dateien einlesen und daraus der Dateiname und der Pfad ermitteln. Soll hingegen nur ein Verzeichnis(name) ermittelt oder ausgewählt werden, ist der Weg über die Dateiauswahl nicht die eleganteste.
An dieser Stelle kann auf den API-Aufruf SHBrowseForFolder zurückgegriffen werden. Mit Hilfe dieses API erhält man ein Dialog-Fenster mit den verfügbaren Verzeichnisbäumen.
Das ausgewählte Verzeichnis kann an eine Variable zurückgegeben und weiter verwendet werden. Dem Aufruf kann auch ein Verzeichnis als Startverzeichnis mitgegeben werden. Im folgenden Beispiel wird der evtl. bereits zurückgegebene Verzeichnisname wieder als Startverzeichnis für den nächsten Aufruf verwendet. Zu beachten ist dabei nur, daß die Variable nur solange zur Verfügung steht, wie die Funktion aktiv ist.
Erfolgt der Aufruf aus einer Userform heraus, bleibt die Variable für die Dauer der Anzeige der Userform gültig. Wird der Aufruf als Funktion in eine Symbolleiste eingefügt, läßt sich das letzte Verzeichnis z.B. in die .Tag-Eigenschaft speichern.

1      Option Explicit 
2       Private Type BROWSEINFO
3          hWndOwner As Long 
4          pidlRoot As Long 
5          pszDisplayName As String 
6          lpszTitle As String 
7          ulFlags As Long 
8          lpFn As Long 
9          lParam As String 
10         iImage As Long 
11      End Type 
12      Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
         Alias "SHBrowseForFolderA" (ByRef lpbi As BROWSEINFO) As Long 
13      Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
         Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
         ByVal pszPath As String) As Long 
14      Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
15      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 
16      Private Const WM_USER As Long = &H400
17      Private Const BIF_RETURNONLYFSDIRS As Long = 1
18      Private Const BFFM_INITIALIZED As Long = 1
19      Private Const BFFM_SETSELECTION As Long = (WM_USER + 102)
20      Private Const MAX_PATH As Long = 260
21      Public Function GetFolderInternal(ByVal Caption As String, _
         ByVal Default As String) As String 
22         Dim BI As BROWSEINFO
23         Dim ListIdx As Long 
24         Dim Path As String 
25         With BI
26            .lpszTitle = Caption
27            .ulFlags = BIF_RETURNONLYFSDIRS
28            .lpFn = MakeFktnPtr(AddressOf BrowseCallbackProc)
29            .lParam = Default 
30         End With 
31         Path = String$(MAX_PATH + 1, vbNullChar)
32         ListIdx = SHBrowseForFolder(BI)
33         If SHGetPathFromIDList(ListIdx, Path) Then 
34            GetFolderInternal = Left$(Path, InStr(Path, vbNullChar) - 1)
35         End If 
36         CoTaskMemFree ListIdx
37      End Function 
38      Private Function BrowseCallbackProc(ByVal hWnd As Long, _
         ByVal Msg As Long, _
         ByVal lParam As Long, _
         ByVal lpData As Long) As Long 
39         On Error Resume Next 
40         If Msg = BFFM_INITIALIZED Then 
41            SendMessage hWnd, BFFM_SETSELECTION, 1&, lpData
42         End If 
43      End Function 
44      Private Function MakeFktnPtr(ByVal FktnPtr As Long) As Long 
45         MakeFktnPtr = FktnPtr
46      End Function