By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
429,365 Members | 3,180 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 429,365 IT Pros & Developers. It's quick & easy.

VBA332.DLL and AccessXP And Getting Current Folder

P: n/a
I designed a small app and I wanted to do a BrowseFolder (see
http://www.mvps.org/access/api/api0002.htm), basically do a file open
diaglog and select a directory/folder. The problem is that you can't
specify the starting folder.

Stephan Leban provided a neat solution that does allow me to browse
using a starting folder.

I am using A97 and it works fine. However, I put it onto a system that
uses AccessXP. And it chokes on references to VBA332.DLL. I searched
the drive on the XP system and there is no VBA332.DLL. That makes
Stephan's utility unworkable.

Is there anything I can use to substitute vba332.dll? Below are the
functions that make refererence to it. Does XP have a "built-in"
browsefolder command where one can specify a starting folder?

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
Nov 13 '05 #1
Share this Question
Share on Google+
8 Replies


P: n/a
I'm not completely sure about compatibility with A97, but I use the Common
Dialog module from "Access 2000 Developer's Handbook" (Getz, Litwin,
Gilbert). I started using it because of the many problems I had experienced
with incompatibility between different client systems. It works flawlessly
on every system I've put it on and allows you to specify a starting
directory.
"Salad" <oi*@vinegar.com> wrote in message
news:UH****************@newsread1.news.pas.earthli nk.net...
I designed a small app and I wanted to do a BrowseFolder (see
http://www.mvps.org/access/api/api0002.htm), basically do a file open
diaglog and select a directory/folder. The problem is that you can't
specify the starting folder.

Stephan Leban provided a neat solution that does allow me to browse
using a starting folder.

I am using A97 and it works fine. However, I put it onto a system that
uses AccessXP. And it chokes on references to VBA332.DLL. I searched
the drive on the XP system and there is no VBA332.DLL. That makes
Stephan's utility unworkable.

Is there anything I can use to substitute vba332.dll? Below are the
functions that make refererence to it. Does XP have a "built-in"
browsefolder command where one can specify a starting folder?

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


Nov 13 '05 #2

P: n/a
Randy Harris wrote:
I'm not completely sure about compatibility with A97, but I use the Common
Dialog module from "Access 2000 Developer's Handbook" (Getz, Litwin,
Gilbert). I started using it because of the many problems I had experienced
with incompatibility between different client systems. It works flawlessly
on every system I've put it on and allows you to specify a starting
directory.


Thanks for the prompt reply. Can you specify the starting directory
with it? For example, I don't want to send someone to MyDocuments (the
usual default) where the user needs to go up several levels then maybe
down several levels. For example, if the current folder is
C:\Test\Testing\TextFiles...I want that to be the starting directory.
Nov 13 '05 #3

P: n/a

"Salad" <oi*@vinegar.com> wrote in message
news:C9***************@newsread1.news.pas.earthlin k.net...
Randy Harris wrote:
I'm not completely sure about compatibility with A97, but I use the Common Dialog module from "Access 2000 Developer's Handbook" (Getz, Litwin,
Gilbert). I started using it because of the many problems I had experienced with incompatibility between different client systems. It works flawlessly on every system I've put it on and allows you to specify a starting
directory.


Thanks for the prompt reply. Can you specify the starting directory
with it? For example, I don't want to send someone to MyDocuments (the
usual default) where the user needs to go up several levels then maybe
down several levels. For example, if the current folder is
C:\Test\Testing\TextFiles...I want that to be the starting directory.


Yes, you sure can.
Nov 13 '05 #4

P: n/a
You are trying to use the A97 version on A2K or higher. Simply download the
A2K version and you will have no trouble. The issue you mentioned has to do
with the fact that AddressOf was natively supported prior to A2K.

--

HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
"Salad" <oi*@vinegar.com> wrote in message
news:UH****************@newsread1.news.pas.earthli nk.net...
I designed a small app and I wanted to do a BrowseFolder (see
http://www.mvps.org/access/api/api0002.htm), basically do a file open
diaglog and select a directory/folder. The problem is that you can't
specify the starting folder.

Stephan Leban provided a neat solution that does allow me to browse using
a starting folder.

I am using A97 and it works fine. However, I put it onto a system that
uses AccessXP. And it chokes on references to VBA332.DLL. I searched the
drive on the XP system and there is no VBA332.DLL. That makes Stephan's
utility unworkable.

Is there anything I can use to substitute vba332.dll? Below are the
functions that make refererence to it. Does XP have a "built-in"
browsefolder command where one can specify a starting folder?

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

Nov 13 '05 #5

P: n/a
The following works
'**************************************
' Code Start
Option Explicit

'******************************
'Code Start
'******************************
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
' lpszTitle As Byte
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
Dim lngPtr As Long
Dim bytBuffer() As Byte

strStartDir = StartDir
BrowseFolder = ""

Call ZeroMemory(VarPtr(BI), Len(BI))

' This has to be 1 element larger than the length
' of the string so that it contains the terminating
' Null character
ReDim bytBuffer(0 To Len(szDialogTitle))
For lngPtr = 1 To Len(szDialogTitle)
bytBuffer(lngPtr - 1) = Asc(Mid(szDialogTitle, lngPtr, 1))
Next

With BI
.pidlRoot = CSIDL_DESKTOP
.hOwner = hWnd
.lpszTitle = VarPtr(bytBuffer(0))
.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, apiTrue, 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
' Code Start
'**************************************

Copy and paste the code above into a module then call the BrowseFolder
function

Sample call:-

Dim strFolder as String

strFolder = BrowseFolder("Find the Folder", "c:\program files")
--
Terry Kreft

"Salad" <oi*@vinegar.com> wrote in message
news:UH****************@newsread1.news.pas.earthli nk.net...
I designed a small app and I wanted to do a BrowseFolder (see
http://www.mvps.org/access/api/api0002.htm), basically do a file open
diaglog and select a directory/folder. The problem is that you can't
specify the starting folder.

Stephan Leban provided a neat solution that does allow me to browse using
a starting folder.

I am using A97 and it works fine. However, I put it onto a system that
uses AccessXP. And it chokes on references to VBA332.DLL. I searched the
drive on the XP system and there is no VBA332.DLL. That makes Stephan's
utility unworkable.

Is there anything I can use to substitute vba332.dll? Below are the
functions that make refererence to it. Does XP have a "built-in"
browsefolder command where one can specify a starting folder?

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

Nov 13 '05 #6

P: n/a
Salad wrote:

Thanks all.
Nov 13 '05 #7

P: n/a
Terry Kreft wrote:

Hi Terry. I can't get your code to work tho the fix looks minor. The
problem exists on the statement line
.lpfn = AddrOf2k(AddressOf BrowseCallbackProc)

If I comment the line out, it works as a normal BrowseFolder and puts me
at MyDocuments. I don't start at "c:\program files" using your example.

The following works
'**************************************
' Code Start
Option Explicit

'******************************
'Code Start
'******************************
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
' lpszTitle As Byte
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
Dim lngPtr As Long
Dim bytBuffer() As Byte

strStartDir = StartDir
BrowseFolder = ""

Call ZeroMemory(VarPtr(BI), Len(BI))

' This has to be 1 element larger than the length
' of the string so that it contains the terminating
' Null character
ReDim bytBuffer(0 To Len(szDialogTitle))
For lngPtr = 1 To Len(szDialogTitle)
bytBuffer(lngPtr - 1) = Asc(Mid(szDialogTitle, lngPtr, 1))
Next

With BI
.pidlRoot = CSIDL_DESKTOP
.hOwner = hWnd
.lpszTitle = VarPtr(bytBuffer(0))
.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, apiTrue, 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
' Code Start
'**************************************

Copy and paste the code above into a module then call the BrowseFolder
function

Sample call:-

Dim strFolder as String

strFolder = BrowseFolder("Find the Folder", "c:\program files")

Nov 13 '05 #8

P: n/a
Salad,
It won't work on A97, you need to use the addrof code from Michael Kaplan
and Ken Getz for that
(http://www.trigeminal.com/lang/1033/...?ItemID=19#19), but it should
work in AccessXp, I've tested it on A2003 and it certainly worked there.

The line you remmed out is the one which hooks the browse dialog to the
callback function. The callback function changes the start dir to whatever
you want, so I'm not surprised it didn't work after you remmed the line.

--
Terry Kreft

"Salad" <oi*@vinegar.com> wrote in message
news:mj*****************@newsread2.news.pas.earthl ink.net...
Terry Kreft wrote:

Hi Terry. I can't get your code to work tho the fix looks minor. The
problem exists on the statement line
.lpfn = AddrOf2k(AddressOf BrowseCallbackProc)

If I comment the line out, it works as a normal BrowseFolder and puts me
at MyDocuments. I don't start at "c:\program files" using your example.

The following works
'**************************************
' Code Start
Option Explicit

'******************************
'Code Start
'******************************
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
' lpszTitle As Byte
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
Dim lngPtr As Long
Dim bytBuffer() As Byte

strStartDir = StartDir
BrowseFolder = ""

Call ZeroMemory(VarPtr(BI), Len(BI))

' This has to be 1 element larger than the length
' of the string so that it contains the terminating
' Null character
ReDim bytBuffer(0 To Len(szDialogTitle))
For lngPtr = 1 To Len(szDialogTitle)
bytBuffer(lngPtr - 1) = Asc(Mid(szDialogTitle, lngPtr, 1))
Next

With BI
.pidlRoot = CSIDL_DESKTOP
.hOwner = hWnd
.lpszTitle = VarPtr(bytBuffer(0))
.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, apiTrue, 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
' Code Start
'**************************************

Copy and paste the code above into a module then call the BrowseFolder
function

Sample call:-

Dim strFolder as String

strFolder = BrowseFolder("Find the Folder", "c:\program files")


Nov 13 '05 #9

This discussion thread is closed

Replies have been disabled for this discussion.