VBA Tipp: Ordnerauswahl-Dialog 2

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

  • Ich möchte den Windows-Ordnerauswahl-Dialog aufrufen, um einen Ordner auszuwählen.
  • Als Ergebnis wird der Pfad zum ausgewählten Ordner geliefert.
  • Als zusätzliche Option kann ein bestimmter Ordner vorausgewählt werden.

Lösung:

Das geht mit der folgenden VBA-Funktion und API-Funktionen, die in einem globalen Modul hinterlegt werden.

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 Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
                         LPBROWSEINFO 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 Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
                         ByVal hWnd As Long, _
                         ByVal Msg As Long, _
                         wParam As Any, _
                         lParam As Any _
                         ) As Long
 
Private Const BIF_RETURNONLYFSDIRS = &H1        'nur Dateisystem-Verzeichnisse anzeigen
Private Const BIF_BROWSEINCLUDEFILES = &H4000   'zusätzlich alle Dateien anzeigen
Private Const BIF_BROWSEFILEJUNCTIONS = &H10000 'zusätzlich nur Dateiarchive z.B. zip-Dateien anzeigen
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SETSELECTION = &H466
Private StartDir As String
 
 
Public Function Ordnerdialog(Optional ByVal Überschrift As String = vbNullString, _
                             Optional ByVal Startverzeichnis As String = vbNullString _
                             ) As String
 
 'Quelle: http://www.dbwiki.net/
 
 Dim BI        As BROWSEINFO
 Dim lngIDList As Long
 Dim strPfad   As String
 
 BI.hwndOwner = hWndAccessApp
 
 'Überschrift im Dialogfeld setzen
 BI.lpszTitle = Überschrift
 
 'Flags
 BI.ulFlags = BIF_RETURNONLYFSDIRS
 
 'Startverzeichnis
 StartDir = Startverzeichnis
 BI.lpfn = Hilfsfunktion(AddressOf BrowseCallbackFunktion)
 
 'Dialogfeld einblenden
 lngIDList = SHBrowseForFolder(BI)
 
 'Rückgabewert
 If lngIDList Then
 
   strPfad = Space(512)
   Call SHGetPathFromIDList(ByVal lngIDList, ByVal strPfad)
   Ordnerdialog = Left(strPfad, InStr(strPfad, Chr(0)) - 1)
 
 'Abbrechen gedrückt (lngIDList = 0)
 Else
   Ordnerdialog = ""
 End If
 
End Function
 
 
Private Function BrowseCallbackFunktion(ByVal hWnd As Long, _
                                        ByVal uMsg As Long, _
                                        ByVal lParam As Long, _
                                        ByVal lpData As Long _
                                        ) As Long
 
 If uMsg = BFFM_INITIALIZED Then
   Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal CLng(1), ByVal StartDir)
 End If
 
 BrowseCallbackFunktion = 0
 
End Function
 
 
Private Function Hilfsfunktion(ByVal param As Long) As Long
 
  Hilfsfunktion = param
 
End Function

Aufruf

 'Beispiel 1: Ordnerauswahldialog öffnen (Standardwerte)
 Dim strPfad As String
 strPfad = Ordnerdialog
 If Not strPfad = "" Then
   MsgBox strPfad
 Else
   'Abbrechen gedrückt
 End If
 'Beispiel 2: Ordnerauswahldialog öffnen, mit Überschrift
 'Den Ordner C:\ zur Vorauswahl anbieten. 
 Dim strPfad As String
 strPfad = Ordnerdialog("Bitte wählen Sie einen Ordner:", "C:\")
 If Not strPfad = "" Then
   MsgBox strPfad
 Else
   'Abbrechen gedrückt
 End If

Wiki-Links

Web-Links