Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" ( _
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)
' Den folgenden in ein Modul einfügen
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
' SendMessage SHBrowseForFolder-Messages
' --------------------------------------
' Enabled den OK-Button, wenn lParam ungleich 0 ist,
' andernfalls wird der Button Disabled
Private Const BFFM_ENABLEOK = &H465
' Setzt die Selektierung auf einen Verzeichnisbaumeintrag
' lParam gibt hierbei den Pfad an und wParam muss ungleich 0 sein
Private Const BFFM_SETSELECTION = &H466
' Setzt den Staustext des Dialogs.
' lParam gibt den auszugebenden Text an
Private Const BFFM_SETSTATUSTEXT = &H464
' Callback Ereignis-Messages
' --------------------------
' Dialog wurde initialisiert, lParam ist 0
Private Const BFFM_INITIALIZED = 1
' Benutzer hat ein anderen Verzeichnisbaumeintrag gewählt
Private Const BFFM_SELCHANGED = 2
' (ab IE 4.0) Benutzer hat eine falsche Angabe
' in der Textbox des Dialogs gemacht
Private Const BFFM_VALIDATEFAILED = 3
Private Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Type SHITEMID
cbSize As Integer
abID As String * 256
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
' Nur Computer als Auswahl erlaubt. Wenn der Anwender andere
' Ordner markiert, kann der OK-Schalter nicht ausgewählt
' werden.
Private Const BIF_BROWSEFORCOMPUTER = &H1000
' Nur Drucker als Auswahl erlaubt. Wenn der Anwender andere
' Ordner markiert, kann der OK-Schalter nicht ausgewählt
' werden.
Private Const BIF_BROWSEFORPRINTER = &H2000
' Der Dialog zeigt neben den Ordnern auch Dateien.
Private Const BIF_BROWSEINCLUDEFILES = &H4000
' Der Dialog zeigt keine Netzwerkordner unterhalb der
' aktuellen Domain.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' Nur Dateisystemobjekte als Auswahl erlaubt. Wenn der
' Anwender andere Ordner markiert, kann der OK-Schalter
' nicht ausgewählt werden.
Private Const BIF_RETURNFSANCESTORS = &H8
' Nur Dateisystemordner als Auswahl erlaubt. Wenn der
' Anwender andere Ordner markiert, kann der OK-Schalter
' nicht ausgewählt werden.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Der Dialog enthält eine Statuszeile. Die Rückruffunktion
' kann die Statuszeile ausfüllen
Private Const BIF_STATUSTEXT = &H4
' (Win 2000) Zeigt ein neuen Dialog an mit mehr
' benutzerfreundlichen Änderungen
Const BIF_USENEWUI = &H40
' (ab IE 4.0) Sendet an die Callback Funktion eine
' BFFM_VALIDATEFAILED Message, wenn in der Textbox eine falsche
' Eingabe gemacht wurde
Const BIF_VALIDATE = &H20
Private Const BIF_EDITBOX = &H10
Public Function BrowseFolder(ByVal WindowHandle as Long) as String
Dim BI As BROWSEINFO
Dim Item As ITEMIDLIST
Dim Retval As Long
Dim RetStr As String * 256
' Dialog-Eigenschaften und Vorgabewerte setzen
With BI
.hwndOwner = WindowHandle
.pszDisplayName = Space(260)
.lpszTitle = "Ordner wählen"
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_VALIDATE Or _
BIF_STATUSTEXT Or BIF_EDITBOX
.lpfn = 0
End With
' Dialog aufrufen
Retval = SHBrowseForFolder(BI)
If Retval = 0 Then
MsgBox "Es ist ein Fehler aufgetreten oder Sie haben " & _
" auf 'Abbrechen' geklickt."
Exit Function
End If
' Ausgewählten Pfad ermitteln
Retval = SHGetPathFromIDList(Retval, RetStr)
If Retval = 0 Then
MsgBox "Fehler beim Extrahieren des ausgewählten Pfades"
Exit Function
End If
BrowseFolder=Left$(RetStr, InStr(1, RetStr, vbNullChar) - 1)
' Ressourcen wieder freigeben
CoTaskMemFree Retval
End Function
