How to make API Browse sticky?
deko
After selecting a folder from the dialog, the full path is returned to a
text box and saved. The next time the user clicks the browse button, he
wants to start browsing from the directory last selected (one level up from
what's in the text box), rather than having to drill down from the root
drive again.
I've done this with AC2002 using the ActiveX version of the Common Dialog,
but not sure how to do it with the API. Any help is appreciated!
Option Compare Database
Option Explicit
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
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function GetFolder(szDialogTitle As String) As String
Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If x Then
wPos = InStr(szPath, Chr(0))
GetFolder = Left$(szPath, wPos - 1)
Else
GetFolder = vbNullString
End If
End Function
The above function is called from a form module with this code:
Private Sub cmdBrowseData_Click()
Dim strFolderPath As String
strFolderPath = basBrowseFolder.GetFolder("Select folder containing data
files:")
If Len(strFolderPath) <> 0 Then
Me!cboData = strFolderPath
Call UpdateDataPath
End If
End Sub
Terry Kreft
Sample call
Dim strDir as string
strDir = BrowseFolder("myTitle")
' Start in the directory last returned
strDir = BrowseFolder("MyTitle2", strDir)
Option Explicit
'******************************
'Code Start
'******************************
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'******************************
'Functions in BrowseFolder
'******************************
Private Declare Function SHGetPathFromIDList _
Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) _
As Long
Private Declare Function SHBrowseForFolder _
Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) _
As Long
Private Declare Sub ZeroMemory _
Lib "kernel32" Alias "RtlZeroMemory" _
(dest As Long, ByVal numBytes As Long)
Private Declare Function lstrcat _
Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, _
ByVal lpString2 As String) _
As Long
'******************************
'/Functions in BrowseFolder
'******************************
Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, _
lpdwHandle As Long) As Long
Private Declare Function GetFileVersionInfo Lib "version.dll" _
Alias "GetFileVersionInfoA" _
(ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
lpData As Any) As Long
Private Declare Function VerQueryValue Lib "version.dll" _
Alias "VerQueryValueA" _
(pBlock As Any, _
ByVal lpSubBlock As String, _
lpBuffer As Any, _
nVerSize As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
'******************************
'Functions used in call back
'******************************
Private Declare Function GetCurrentDirectory _
Lib "kernel32" Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) _
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
'******************************
'/Functions used in call back
'******************************
'******************************
'Root pidls
'******************************
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
'******************************
'Root pidls
'******************************
'******************************
'uFlag consts
'******************************
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
'******************************
'/uFlag consts
'******************************
Private Const WM_USER = &H400
'******************************
'Messages from dialog consts
'******************************
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_VALIDATEFAILEDA = 3
Private Const BFFM_VALIDATEFAILED = BFFM_VALIDATEFAILEDA
'******************************
'/Messages from dialog consts
'******************************
'******************************
'Messages to dialog consts
'******************************
Private Const BFFM_SETSELECTIONA = WM_USER + 102
Private Const BFFM_SETSELECTION = BFFM_SETSELECTIONA
Private Const BFFM_SETSTATUSTEXTA = WM_USER + 100
Private Const BFFM_SETSTATUSTEXT = BFFM_SETSTATUSTEXTA
'******************************
'/Messages to dialog consts
'******************************
Private Const MAX_PATH = 260
Private strStartDir As String
'
Public Function BrowseFolder(szDialogTitle As String, _
Optional StartDir As String = vbNullString, Optional hWnd As Long = 0) As
String
'*******************************************
'Name: BrowseFolder (Function)
'Purpose: Open API browse for folder dialog
'Author: Terry Kreft
'Date: January 28, 2001, 09:50:20
'Called by: Any
'Calls: AddrOf _
Various API calls defined on this module
'Inputs: szDialogTitle - dialog prompt _
StartDir - Directory to start the _
browse in (Optional)
'Output: Directory selected in browse folder
'*******************************************
Dim x As Long
Dim BI As BROWSEINFO
Dim dwIList As Long
Dim szPath As String
Dim wPos As Integer
strStartDir = StartDir
BrowseFolder = ""
Call ZeroMemory(VarPtr(BI), Len(BI))
With BI
.pidlRoot = CSIDL_DESKTOP
.hOwner = hWnd
.lpszTitle = lstrcat(szDialogTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT _
Or BIF_EDITBOX Or BIF_VALIDATE
If IsShellVersion(5) Then
.ulFlags = .ulFlags Or BIF_NEWDIALOGSTYLE
End If
.lpfn = AddrOf2k(AddressOf BrowseCallbackProc)
End With
dwIList = SHBrowseForFolder(BI)
If dwIList Then
szPath = Space$(512)
x = SHGetPathFromIDList(dwIList, szPath)
If x Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
End If
End If
End Function
Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal lp As Long, ByVal pData As Long) As Long
'*******************************************
'Name: BrowseCallbackProc (Function)
'Purpose: Call back function for BrowseFolder
'Author: Terry Kreft
'Date: January 28, 2001, 09:52:56
'Called by: API Browse Folder dialog
'Calls: Various API functions
'Inputs: See MSDN for description of inputs
'Output:
'*******************************************
Dim lngRet As Long
Dim nBufferLength As Long
Dim lpBuffer As String
Const apiTrue = 1
Const apiFalse = 0
Const BAD_DIR = "The directory selected is invalid." _
& vbCrLf _
& "Do you want to try again"
lngRet = apiFalse
Select Case uMsg
Case BFFM_INITIALIZED
If Len(strStartDir) < 1 Then
nBufferLength = MAX_PATH
lpBuffer = String(MAX_PATH, 0)
If GetCurrentDirectory(nBufferLength, lpBuffer) Then
Call SendMessage(hWnd, BFFM_SETSELECTION, apiTrue, ByVal lpBuffer)
End If
Else
Call SendMessage(hWnd, BFFM_SETSELECTION, apiTrue, ByVal strStartDir)
End If
Case BFFM_SELCHANGED
'Set the status window to the currently selected path.
lpBuffer = String(MAX_PATH, 0)
If SHGetPathFromIDList(lp, lpBuffer) Then
lpBuffer = Left(lpBuffer, InStr(lpBuffer, Chr(0)) - 1)
Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, ByVal lpBuffer)
End If
Case BFFM_VALIDATEFAILED
'If the user types an invalid path
If MsgBox(BAD_DIR, vbYesNo) = vbYes Then
lngRet = apiTrue
End If
' Case BFFM_IUNKNOWN
Case Else
Debug.Print uMsg
End Select
BrowseCallbackProc = lngRet
End Function
Function AddrOf2k(ByVal lngFnPtr As Long) As Long
AddrOf2k = lngFnPtr
End Function
'******************************
'Code End
'******************************
Private Function IsShellVersion(ByVal version As Long) As Boolean
'returns True if the Shell version
'(shell32.dll) is equal or later than
'the value passed as 'version'
Dim nBufferSize As Long
Dim nUnused As Long
Dim lpBuffer As Long
Dim nVerMajor As Integer
Dim bBuffer() As Byte
Const sDLLFile As String = "shell32.dll"
nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
If nBufferSize > 0 Then
ReDim bBuffer(nBufferSize - 1) As Byte
Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
IsShellVersion = nVerMajor >= version
End If 'VerQueryValue
End If 'nBufferSize
End Function
--
Terry Kreft
MVP Microsoft Access
"deko" <de...@deko.com> wrote in message
news:Gq1be.225$zu...@newssvr13.news.prodigy.com...
deko
Thanks - I'll give it a shot and post back
deko
>
> Sample call
> Dim strDir as string
> strDir = BrowseFolder("myTitle")
>
> ' Start in the directory last returned
> strDir = BrowseFolder("MyTitle2", strDir)
I looked through the code you posted, but it's a bit much. I'd rather just
make minor adjustments to the code I have. But from what you've posted, it
seems I need to add some functions...
Do I need to have this at the top of the module?
> Private Declare Function GetCurrentDirectory _
> Lib "kernel32" Alias "GetCurrentDirectoryA" _
> (ByVal nBufferLength As Long, _
> ByVal lpBuffer As String) _
> 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
And then somehow call those functions?
I'm not very good with API calls. Is there an easy way to modify my code to
make the start folder the location I pass into the function (i.e. a string
that is a path to a folder)?
Here again is my code:
Option Compare Database
Option Explicit
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
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function GetFolder(szDialogTitle As String) As String
Dim x As Long
Dim bi As BROWSEINFO
Dim dwIList As Long
Dim szPath As String
Dim wPos As Integer
Terry Kreft
code which will do what yopu want.
Put the code I gave you into a module and then just call the BrowseFolder
function. You don't have to understand or call the API functions, the code
I gave you calls them.
--
Terry Kreft
MVP Microsoft Access
"deko" <de...@deko.com> wrote in message
news:2MHbe.1885$zu....@newssvr13.news.prodigy.com...
deko
> code which will do what yopu want.
>
> Put the code I gave you into a module and then just call the BrowseFolder
> function. You don't have to understand or call the API functions, the
code
> I gave you calls them.
10-4. Thanks for the help.