AW: Ordner öffnen
04.02.2004 11:46:57
AndreasS
Hallo,
' Quelle: http://www.chf-online.de/vba/ordnerauswahl.htm
'An dieser Stelle kann auf den API-Aufruf SHBrowseForFolder zurückgegriffen werden.
'Mit Hilfe dieses API erhält man ein Dialog-Fenster mit den verfügbaren
'Verzeichnisbäumen.
'Das ausgewählte Verzeichnis kann an eine Variable zurückgegeben
'und weiter verwendet werden. Dem Aufruf kann auch ein Verzeichnis
'als Startverzeichnis mitgegeben werden. Im folgenden Beispiel wird der evtl.
'bereits zurückgegebene Verzeichnisname wieder als Startverzeichnis für den
'nächsten Aufruf verwendet. Zu beachten ist dabei nur,
'daß die Variable nur solange zur Verfügung steht, wie die Funktion aktiv ist.
Sub Ordnerauswahl()
Dim Verzeichnis As String
Verzeichnis2 = GetFolderInternal(Verzeichnis, Verzeichnis)
End Sub
'Und in ein extra Modul:
Option Explicit
Private Type BROWSEINFO
hWndOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpFn As Long
lParam As String
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (ByRef 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)
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
Private Const WM_USER As Long = &H400
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SETSELECTION As Long = (WM_USER + 102)
Private Const MAX_PATH As Long = 260
Public Function GetFolderInternal(ByVal Caption As String, _
ByVal Default As String) As String
Dim BI As BROWSEINFO
Dim ListIdx As Long
Dim Path As String
With BI
.lpszTitle = Caption
.ulFlags = BIF_RETURNONLYFSDIRS
.lpFn = MakeFktnPtr(AddressOf BrowseCallbackProc)
.lParam = Default
End With
Path = String$(MAX_PATH + 1, vbNullChar)
ListIdx = SHBrowseForFolder(BI)
If SHGetPathFromIDList(ListIdx, Path) Then
GetFolderInternal = Left$(Path, InStr(Path, vbNullChar) - 1)
End If
CoTaskMemFree ListIdx
End Function
Private Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
On Error Resume Next
If Msg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSELECTION, 1&, lpData
End If
End Function
Private Function MakeFktnPtr(ByVal FktnPtr As Long) As Long
MakeFktnPtr = FktnPtr
End Function
Gruß Andreas