1    Sub Ordnerauswahl()
2    Dim Verzeichnis As String 
3    Verzeichnis2 = GetFolderInternal(Verzeichnis, Verzeichnis)
4    End Sub 

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