Verzeichnis wählen

Mit diesem Code kann man den Windows-eigenen Dialog zur Verzeichnisauswahl aufrufen. Der Anfangspfad kann gesetzt werden, wobei man für die Call-Back-Funktion einen Funktionszeiger braucht. Office-Versionen >= XL 2000 haben AddressOf, unter XL 97 bekommt man einen Zeiger dank M. Kaplan und K. Getz. Bei mir unter Win XP hat das Setzen des Dialogtitels nicht geklappt, warum, weiß der Geier. Ich bin der Meinung, dass das unter Win 98 schon mal durch Setzen der Browseinfostruktur gefunzt hat. Dann halt eben mit Gewalt.

Beispieldatei (browsefolder.zip 19 KB)
'*************************************
* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
*************************************
Private Declare Function GetVbaProjekt _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hVBA As Long) As Long

Private Declare Function GetFunktionsnummerString _
Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hVBA As Long, ByVal strFuncNameUnicode _
As String, strFunktionsnummer As String) As Long

Private Declare Function GetFunktionsnummerLong _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
(ByVal hVBA As Long, ByVal strFunktionsnummer _
As String, hlngFunction As Long) As Long
'*************************************
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BROWSEINFO) As Long

Private Declare Function SHGetPathFromIDList _
Lib "shell32" (ByVal pidList As Long, _
ByVal lpBuffer As String) As Long

Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String) As Long

Private Type BROWSEINFO
  hwndOwner As Long
  pidlRoot As Long
  pszDisplayName As Long
  lpszTitle As Long
  ulFlags As Long
  lpfnCallback As Long
  lParam As Long
  iImage As Long
End Type

Private Const RETURNONLYFSDIRS = &H3
Private Const WM_SETTEXT = &HC
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam As Long, _
  ByVal lParam As String) As Long
Private strStartdirectory As String
Private strTitelDialog As String

Sub Test()
  MsgBox VBGetFolder("Ordner wählen", "c:\windows")
End Sub

Private Function Startdirectory(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal lp As Long, ByVal pData As Long) As Long
  'Diese Funktion wird vom Dialog aufgerufen
  If uMsg = BFFM_INITIALIZED Then
    'Wenn Dialog initialisiert wird
    If Len(strStartdirectory) > 1 Then
      'Jetzt wird das Startverzeichnis gesetzt
      SendMessage hwnd, BFFM_SETSELECTION, 1, strStartdirectory
    End If
    'Da Titel setzen bei mir unter Win XP nicht
    'Funktioniert, machen wir es hier
    SetWindowText hwnd, strTitelDialog
  End If
End Function

Public Function VBGetFolder(Titel As String, Startdir As String) As String
Dim lngListID As Long
Dim strBuffer As String
Dim udtBrowseInfo As BROWSEINFO
  'Funktioniert auch ohne vbNullChar
  strStartdirectory = Startdir & vbNullChar
  'Funktioniert auch ohne vbNullChar
  Titel = Titel & vbNullChar
  strTitelDialog = Titel
  With udtBrowseInfo
    .hwndOwner = 0
    'Funktioniert bei mir nicht (Win XP)
    '.lpszTitle = StrPtr(Titel)
    .ulFlags = RETURNONLYFSDIRS
    'XL 97
    .lpfnCallback = GetFuncAdress("Startdirectory")
    'Versionen > XL97
    '.lpfnCallback = AddressOf_ToLong(AddressOf Startdirectory)
  End With
  lngListID = SHBrowseForFolder(udtBrowseInfo)
  If lngListID Then
    strBuffer = String(512, 0)
    SHGetPathFromIDList lngListID, strBuffer
    strBuffer = Left(strBuffer, InStr(strBuffer, Chr(0)) - 1)
    VBGetFolder = strBuffer
  End If
End Function

Private Function AddressOf_ToLong(ByVal FPointer As Long) As Long
  'Wenn AddressOf in Versionen > XL97 benutzt wird
  'ist diese auf dem ersten Blick unnötige Funktion wichtig
  AddressOfToLong = FPointer
End Function

'*************************************
'* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
'*************************************
Public Function GetFuncAdress&(strFunktion$)
Dim hVBA&, lngRück&, strFunktionsnummer$
Dim hlngFunction&, strFuncNameUnicode$
  strFuncNameUnicode = StrConv(strFunktion, vbUnicode)
  GetVbaProjekt hVBA
  If hVBA <> 0 Then
    lngRück = GetFunktionsnummerString(hVBA, _
    strFuncNameUnicode, strFunktionsnummer)
    If lngRück = 0 Then
      lngRück = GetFunktionsnummerLong(hVBA, _
      strFunktionsnummer, hlngFunction)
      If lngRück = 0 Then GetFuncAdress = _
        hlngFunction
    End If
  End If
End Function