Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Dialog Box for Path only 2
- Thread starter wkilgroe
- Start date
-
2
- #2
Use the Browse For Folder dialog:
hth
Ben
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
hth
Ben
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
- Thread starter
- #3
Now you're getting into dark places! You are into the world of api calls and even darker still api callback functions.
To be honest, you don't need to know much about what is going on, just how to use it.
Here is a load of code to copy into a module.
To use it just call the BrowseForFolderByPath function which returns the chosen folder. You need to pass the starting folder & dialog title.
The starting folder must be stripped of any final /'s which the function UnqualifyPath makes sure of.
You will need Access 2k or above to run this code as it is. It can be made to work in Access 97, but that's even uglier!
You can't step through this code a line at a time as it will crash out if you do.
Have fun,
Ben
Option Compare Database
Option Explicit
'--------------------------------------------------------------
' Copyright ©1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Terms of use '--------------------------------------------------------------
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
Public Declare Function SHBrowseForFolder Lib "shell32" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.
'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
'If the lParam parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
"shell32" Alias "#162" _
(ByVal szPath As String) As Long
'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Public Declare Function lstrcpyA Lib "kernel32" _
(lpString1 As Any, lpString2 As Any) As Long
Public Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT = 2
Public Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Sub BrowseForFolderExample()
Dim spath As String
'The call can not have a trailing slash, so
'strip it from the path if present
spath = UnqualifyPath(("G:\bpo\"
)
'call the function, returning the path
'selected (or blank if cancelled)
Debug.Print BrowseForFolderByPath(spath, "Select A Folder"
End Sub
Public Function BrowseForFolderByPath(sSelPath As String, sDialogTitle As String) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim spath As String * MAX_PATH
With BI
.hOwner = Application.hWndAccessApp
.pidlRoot = 0
.lpszTitle = sDialogTitle
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, spath) Then
BrowseForFolderByPath = Left$(spath, InStr(spath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
End Function
Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case Else:
End Select
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse PIDL method.
'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
False, ByVal lpData)
Case Else:
End Select
End Function
Public Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Function IsWinNT() As Boolean
#If Win32 Then
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
'API returns 1 if a successful call
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing
'the OS, so if it's VER_PLATFORM_WIN32_NT,
'return true
IsWinNT = OSV.PlatformID = VER_PLATFORM_WIN32_NT
End If
#End If
End Function
Public Function UnqualifyPath(spath As String) As String
'Qualifying a path involves assuring that its format
'is valid, including a trailing slash, ready for a
'filename. Since SHBrowseForFolder will not pre-select
'the path if it contains the trailing slash, it must be
'removed, hence 'unqualifying' the path.
If Len(spath) > 0 Then
If Right$(spath, 1) = "\" Then
UnqualifyPath = Left$(spath, Len(spath) - 1)
Exit Function
End If
End If
UnqualifyPath = spath
End Function
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
To be honest, you don't need to know much about what is going on, just how to use it.
Here is a load of code to copy into a module.
To use it just call the BrowseForFolderByPath function which returns the chosen folder. You need to pass the starting folder & dialog title.
The starting folder must be stripped of any final /'s which the function UnqualifyPath makes sure of.
You will need Access 2k or above to run this code as it is. It can be made to work in Access 97, but that's even uglier!
You can't step through this code a line at a time as it will crash out if you do.
Have fun,
Ben
Option Compare Database
Option Explicit
'--------------------------------------------------------------
' Copyright ©1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Terms of use '--------------------------------------------------------------
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
Public Declare Function SHBrowseForFolder Lib "shell32" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.
'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
'If the lParam parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
"shell32" Alias "#162" _
(ByVal szPath As String) As Long
'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Public Declare Function lstrcpyA Lib "kernel32" _
(lpString1 As Any, lpString2 As Any) As Long
Public Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT = 2
Public Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Sub BrowseForFolderExample()
Dim spath As String
'The call can not have a trailing slash, so
'strip it from the path if present
spath = UnqualifyPath(("G:\bpo\"
)'call the function, returning the path
'selected (or blank if cancelled)
Debug.Print BrowseForFolderByPath(spath, "Select A Folder"
End Sub
Public Function BrowseForFolderByPath(sSelPath As String, sDialogTitle As String) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim spath As String * MAX_PATH
With BI
.hOwner = Application.hWndAccessApp
.pidlRoot = 0
.lpszTitle = sDialogTitle
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, spath) Then
BrowseForFolderByPath = Left$(spath, InStr(spath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
End Function
Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case Else:
End Select
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse PIDL method.
'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
False, ByVal lpData)
Case Else:
End Select
End Function
Public Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Function IsWinNT() As Boolean
#If Win32 Then
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
'API returns 1 if a successful call
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing
'the OS, so if it's VER_PLATFORM_WIN32_NT,
'return true
IsWinNT = OSV.PlatformID = VER_PLATFORM_WIN32_NT
End If
#End If
End Function
Public Function UnqualifyPath(spath As String) As String
'Qualifying a path involves assuring that its format
'is valid, including a trailing slash, ready for a
'filename. Since SHBrowseForFolder will not pre-select
'the path if it contains the trailing slash, it must be
'removed, hence 'unqualifying' the path.
If Len(spath) > 0 Then
If Right$(spath, 1) = "\" Then
UnqualifyPath = Left$(spath, Len(spath) - 1)
Exit Function
End If
End If
UnqualifyPath = spath
End Function
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
- Thread starter
- #5
Ouch!
A97 doesn't have the addressof callback function, so you need to recreate that!
Create a new module and call put all this into it.
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
'-------------------------------------------------------------------------------------------------------------------
' AddrOf
'
' 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
Then change your Browse code to:
Option Compare Database
Option Explicit
'--------------------------------------------------------------
' Copyright ©1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Terms of use '--------------------------------------------------------------
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
Public Declare Function SHBrowseForFolder Lib "shell32" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.
'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
'If the lParam parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
"shell32" Alias "#162" _
(ByVal szPath As String) As Long
'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Public Declare Function lstrcpyA Lib "kernel32" _
(lpString1 As Any, lpString2 As Any) As Long
Public Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT = 2
Public Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Sub BrowseForFolderExample()
Dim sPath As String
'The call can not have a trailing slash, so
'strip it from the path if present
sPath = UnqualifyPath(("G:\bpo\")
'call the function, returning the path
'selected (or blank if cancelled)
Debug.Print BrowseForFolderByPath(sPath, "Select A Folder"
End Sub
Public Function BrowseForFolderByPath(sSelPath As String, sDialogTitle As String) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
With BI
.hOwner = Application.hWndAccessApp
.pidlRoot = 0
.lpszTitle = sDialogTitle
.lpfn = FARPROC(AddrOf("BrowseCallbackProcStr")
lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
End Function
Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case Else:
End Select
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse PIDL method.
'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
False, ByVal lpData)
Case Else:
End Select
End Function
Public Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Function IsWinNT() As Boolean
#If Win32 Then
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
'API returns 1 if a successful call
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing
'the OS, so if it's VER_PLATFORM_WIN32_NT,
'return true
IsWinNT = OSV.PlatformID = VER_PLATFORM_WIN32_NT
End If
#End If
End Function
Public Function UnqualifyPath(sPath As String) As String
'Qualifying a path involves assuring that its format
'is valid, including a trailing slash, ready for a
'filename. Since SHBrowseForFolder will not pre-select
'the path if it contains the trailing slash, it must be
'removed, hence 'unqualifying' the path.
If Len(sPath) > 0 Then
If Right$(sPath, 1) = "\" Then
UnqualifyPath = Left$(sPath, Len(sPath) - 1)
Exit Function
End If
End If
UnqualifyPath = sPath
End Function
You'll have to tell me what happens, I don't have a 97 machine handy.
B
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
A97 doesn't have the addressof callback function, so you need to recreate that!
Create a new module and call put all this into it.
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
'-------------------------------------------------------------------------------------------------------------------
' AddrOf
'
' 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
Then change your Browse code to:
Option Compare Database
Option Explicit
'--------------------------------------------------------------
' Copyright ©1996-2002 VBnet, Randy Birch, All Rights Reserved.
' Terms of use '--------------------------------------------------------------
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
Public Declare Function SHBrowseForFolder Lib "shell32" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
pSource As Any, _
ByVal dwLength As Long)
Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.
'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
'If the lParam parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
"shell32" Alias "#162" _
(ByVal szPath As String) As Long
'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
(ByVal uFlags As Long, _
ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" _
(ByVal hMem As Long) As Long
Public Declare Function lstrcpyA Lib "kernel32" _
(lpString1 As Any, lpString2 As Any) As Long
Public Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT = 2
Public Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Sub BrowseForFolderExample()
Dim sPath As String
'The call can not have a trailing slash, so
'strip it from the path if present
sPath = UnqualifyPath(("G:\bpo\"
)'call the function, returning the path
'selected (or blank if cancelled)
Debug.Print BrowseForFolderByPath(sPath, "Select A Folder"
End Sub
Public Function BrowseForFolderByPath(sSelPath As String, sDialogTitle As String) As String
Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH
With BI
.hOwner = Application.hWndAccessApp
.pidlRoot = 0
.lpszTitle = sDialogTitle
.lpfn = FARPROC(AddrOf("BrowseCallbackProcStr"
)lpSelPath = LocalAlloc(LPTR, Len(sSelPath) + 1)
CopyMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath) + 1
.lParam = lpSelPath
End With
pidl = SHBrowseForFolder(BI)
If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(pidl)
End If
Call LocalFree(lpSelPath)
End Function
Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse STRING method.
'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
True, ByVal lpData)
Case Else:
End Select
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long
'Callback for the Browse PIDL method.
'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.
Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
False, ByVal lpData)
Case Else:
End Select
End Function
Public Function FARPROC(pfn As Long) As Long
'A dummy procedure that receives and returns
'the value of the AddressOf operator.
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)
FARPROC = pfn
End Function
Public Function IsWinNT() As Boolean
#If Win32 Then
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
'API returns 1 if a successful call
If GetVersionEx(OSV) = 1 Then
'PlatformId contains a value representing
'the OS, so if it's VER_PLATFORM_WIN32_NT,
'return true
IsWinNT = OSV.PlatformID = VER_PLATFORM_WIN32_NT
End If
#End If
End Function
Public Function UnqualifyPath(sPath As String) As String
'Qualifying a path involves assuring that its format
'is valid, including a trailing slash, ready for a
'filename. Since SHBrowseForFolder will not pre-select
'the path if it contains the trailing slash, it must be
'removed, hence 'unqualifying' the path.
If Len(sPath) > 0 Then
If Right$(sPath, 1) = "\" Then
UnqualifyPath = Left$(sPath, Len(sPath) - 1)
Exit Function
End If
End If
UnqualifyPath = sPath
End Function
You'll have to tell me what happens, I don't have a 97 machine handy.
B
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
- Thread starter
- #7
Oharab,
I added your module and it works fine. What I was looking to is add a save as function that would allow the user to use the common dialog api to select a file and then set a default folder to save the new file to. Any suggestions.
Thanks
I added your module and it works fine. What I was looking to is add a save as function that would allow the user to use the common dialog api to select a file and then set a default folder to save the new file to. Any suggestions.
Thanks
To use the open/save dialog use the code on:
the bit you need to change is the InitialDir variable.
hth
Ben
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
the bit you need to change is the InitialDir variable.
hth
Ben
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
oharab,
Is their anyway I can limit this to only one directory. Althought I change the INITDIR they can still browse throughout other folders. Also can this dir be called up from a text field from within the form. What I need is the ability for a user to 1. Select from a drop down a list of folders, 2. they would browse to select a document and 3. they would save that document onto a network folder specified within the drop down in step-one. I have the common dialog to open and to return a path into a table, can at least have the save funtion find that path and move the document into a specified folder. Let me know if you have any coding ideas.
Thanks
Is their anyway I can limit this to only one directory. Althought I change the INITDIR they can still browse throughout other folders. Also can this dir be called up from a text field from within the form. What I need is the ability for a user to 1. Select from a drop down a list of folders, 2. they would browse to select a document and 3. they would save that document onto a network folder specified within the drop down in step-one. I have the common dialog to open and to return a path into a table, can at least have the save funtion find that path and move the document into a specified folder. Let me know if you have any coding ideas.
Thanks
If you know what directory the file must be saved in, why don't you just pop up an input box or something similar and ask for the file name?
Failing that, you have to trust your users to save in the right place!
B
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
Failing that, you have to trust your users to save in the right place!
B
----------------------------------------------
Ben O'Hara
"Where are all the stupid people from...
...And how'd they get so dumb?"
NoFX-The Decline
----------------------------------------------
How thought in the module or the subroutine can I call in the selected directory. People will have documents dealing with communications, bid, and so on and they will select the location of each of these folders that are on the network. I have not found anything that will allow me to designate a text field in a form as the place to save the file. So the directories will change depending on the user input.
Vladi
Vladi
- Status
Similar threads
- Question
- Locked
- Question
- Locked
- Question
- Locked
- Question