Odnerauswahl mit SHBrowseForFolder
18.12.2009 08:48:43
Erich
Hi Franz,
wenn du das möchtest, probiewrs mal damit: (Quelle steht im Code)
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
' www.chf-online.de/vba/ordnerauswahl.htm
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)
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 Function
Private Function MakeFktnPtr(ByVal FktnPtr As Long) As Long
MakeFktnPtr = FktnPtr
End Function
Sub Ordnerauswahl()
Dim strVz As String
strVz = GetFolderInternal("ein Text", "c:\test")
MsgBox strVz
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort