Zurück zur Homepage

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