API: SHBrowseForFolder, DefaultFolder vorgeben
Jörg Ackermann
wie kann ich der SHBrowseForFolder-API
einen Default-Wert mitgeben, der beim Öffnen des
Dialogs bereits markiert ist ?
wo und wie muß das in die BROWSEINFO rein ?
Private Type BROWSEINFO
hOwner 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
Danke schon mal !
-------------------------------------------------
A-Soft.A...@t-online.de
-------------------------------------------------
Tilo Schinke
<Beginn Quellcode>
-----------------------------------------------------------
Option Compare Database
Option Explicit
'---------------------------------------------------------------------------
----------------------------------------
' Declarations
'
' These function names were puzzled out by using DUMPBIN /exports
' with VBA332.DLL and then puzzling out parameter names and types
' through a lot of trial and error and over 100 IPFs in MSACCESS.EXE
' and VBA332.DLL.
'
' These parameters may not be named properly but seem to be correct in
' light of the function names and what each parameter does.
'
' EbGetExecutingProj: Gives you a handle to the current VBA project
' TipGetFunctionId: Gives you a function ID given a function name
' TipGetLpfnOfFunctionId: Gives you a pointer a function given its function
ID
'
'---------------------------------------------------------------------------
----------------------------------------
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias
"EbGetExecutingProj" (hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId"
(ByVal hProject As Long, ByVal strFunctionName As String, ByRef
strFunctionId As String) As Long
Private Declare Function GetAddr Lib "vba332.dll" Alias
"TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As
String, ByRef lpfn As Long) As Long
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 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, lParam As
Any) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest
As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long,
ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As
Long
Private Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any,
lpString2 As Any) As Long
Private Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Public Type BROWSEINFO
hOwner 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
' Maximum long filename path length
Public Const MAX_PATH = 260
Public Const BFFM_INITIALIZED = 1
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA = (WM_USER + 102)
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
'---------------------------------------------------------------------------
--------------
'
' Function BrowseFolder
'
' Parameters: sSelPath : Set pre-selecting folder
' sTitle : Set the dialog's prompt string
'
' Return: a String with the select Path or an empty string when canceled
'
' Description: Shows the Browse For Folder dialog, pre-selecting the
' folder specified by sSelPath.
' If successful, returns the selected folder's full path,
' returns an empty string otherwise.
'
'---------------------------------------------------------------------------
--------------
Public Function BrowseFolder(Optional sSelPath As String = "C:\", Optional
sTitle As String = "Bitte wählen Sie ein Verzeichnis aus...") As String
Dim bi As BROWSEINFO
Dim pidlRtn As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
While Right(sSelPath, 1) = vbNullChar
sSelPath = Left(sSelPath, Len(sSelPath) - 1)
Wend
If Len(sSelPath) > 3 Then
While Right(sSelPath, 1) = "\"
sSelPath = Left(sSelPath, Len(sSelPath) - 1)
Wend
End If
sSelPath = sSelPath & vbNullChar
With bi
' The desktop will own the dialog
.hOwner = 0
' The desktop folder will be the dialog's root folder.
' SHSimpleIDListFromPath can also be used to set this value.
.pidlRoot = 0
' Set the dialog's prompt string
.lpszTitle = sTitle
' Obtain and set the address of the callback function.
' Note: the AddressOf operator is in Access 97 not available,
' therefore use the function AddrOf to set the address of
' the callback function.
.lpfn = AddrOf("BrowseCallbackProc")
' Now the fun part, allocate some memory for the dialog's
' selected folder path (sSelPath), blast the string into the allocated
' memory, and set the value of the returned pointer to lParam.
' (checking LocalAlloc's success is omitted for brevity)
' Note: VB's StrPtr function won't work here because a variable's
' memory address goes out of scope when passed to SHBrowseForFolder.
lpSelPath = LocalAlloc(LPTR, Len(sSelPath))
MoveMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
lpSelPath = LocalAlloc(LPTR, Len(sSelPath))
MoveMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
.lParam = lpSelPath
End With
pidlRtn = SHBrowseForFolder(bi)
If pidlRtn Then
' Get the path from the selected folder's pidl returned
' from the SHBrowseForFolder call (rtns True on success,
' sPath must be pre-allocated!)
If SHGetPathFromIDList(pidlRtn, sPath) Then
' Return the path
BrowseFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
' Free the memory the shell allocated for the pidl.
Call CoTaskMemFree(pidlRtn)
End If
' Free our allocated string pointer
Call LocalFree(lpSelPath)
End Function
'---------------------------------------------------------------------------
--------------
'
' Function BrowseCallbackProc
'
' Description: And the callback...
'
'---------------------------------------------------------------------------
--------------
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
Select Case uMsg
Case BFFM_INITIALIZED
' Set the dialog's pre-selected folder from the pointer to the path
' we allocated in bi.lParam above (passed in the lpData param).
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
True, ByVal StrFromPtrA(lpData))
End Select
End Function
'---------------------------------------------------------------------------
--------------
'
' Function StrFromPtrA
'
' Description: Returns an ANSII string from a pointer to an ANSII string.
'
'---------------------------------------------------------------------------
--------------
Public Function StrFromPtrA(lpszA As Long) As String
Dim sRtn As String
sRtn = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal sRtn, ByVal lpszA)
StrFromPtrA = sRtn
End Function
'---------------------------------------------------------------------------
----------------------------------------
'
' Function AddrOf
'
' Parameters: strFuncName : String with the Name of Function
'
' Description: Returns a function pointer of a VBA public function given its
name. This function
' gives similar functionality to VBA as VB5 has with the AddressOf param
type.
'
' NOTE: This function only seems to work if the proc you are trying to get a
pointer
' to is in the current project. This makes sense, since we are using a
function
' named EbGetExecutingProj.
'
'---------------------------------------------------------------------------
----------------------------------------
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
' The function name must be in Unicode, so convert it.
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
' Get the current VBA project
' The results of GetCurrentVBAProject seemed inconsistent, in our tests,
' so now we just check the project handle when the function returns.
Call GetCurrentVbaProject(hProject)
' Make sure we got a project handle... we always should, but you never know!
If hProject <> 0 Then
' Get the VBA function ID (whatever that is!)
lngResult = GetFuncID( _
hProject, strFuncNameUnicode, strID)
' We have to check this because we GPF if we try to get a function pointer
' of a non-existent function.
If lngResult = NO_ERROR Then
' Get the function pointer.
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
<Ende Quellcode>
--------------------------------------
Tilo Schinke
Sch...@alfasystem.com
--------------------------------------
Jörg Ackermann
Danke !
-------------------------------------------------
A-Soft.A...@t-online.de
-------------------------------------------------
Tilo Schinke <Tilo.S...@t-online.de> schrieb in Nachricht
76vt8q$3ap$1...@news03.btx.dtag.de...///
Klaus Oberdalhoff
danke.
Diese Funktion klappt auch mit NT. Ich nehme mal an, daß es sich um eine
Adaption des Codes von Terry Kreft und Dev Ashish handelt <g> ?
mfg
Klaus
PS:Tips und Tricks zu ACCESS 97 (** KnowHow-MDB ** Ver 2.0) unter
http://www.accessware.de/ oder
http://www.freeaccess.de
PPS: bitte XXX aus meiner EMail-Adresse entfernen (SpamSchutz)
Tilo Schinke <Tilo.S...@t-online.de> wrote in message
news:76vt8q$3ap$1...@news03.btx.dtag.de...
>Das geht wie folgt:
>
><Beginn Quellcode>
...[Quellcode gelöscht]...
Tilo Schinke
Du schreibst:
>Diese Funktion klappt auch mit NT. Ich nehme mal an, daß es sich um eine
>Adaption des Codes von Terry Kreft und Dev Ashish handelt <g> ?
Woher ich genau die einzelnen Teile habe weiss ich auch nicht mehr so ganz
genau. Beispiele des Verzeichnisbaum mit der SHBrowseForFolder API-Funktion
gibt es ja im Internet zu Hauf.
Irgendwo bin ich durch Zufall auf die Funktion AddrOF in einem anderen
Zusammenhang (Excel-VBA) gestossen und habe diese dann ähnlich der
BrowseForFolder-Beispiele in VB5, Delphi oder C verwendet.
Einzigstes Problem war dann noch die 0-Terminierung der Strings (ein eher
kleines Problem).
Der Rest hat sich von alleine ergeben.
Übrigens: ich entwickle nur noch unter NT und kenne seither die
Win9x-Abstürze nicht mehr (dafür aber andere, nur seltener), daher wundert
mich Dein Hinweis "Diese Funktion klappt auch mit NT" - dachte immer das
geht nur damit ;-)