browse for folder code

  • Thread starter Thread starter Mark Andrews
  • Start date Start date
M

Mark Andrews

I am using this code to browse for a folder (just folders no files) in
Access 2007.
It works great, I just want one extra feature:
- to supply a starting folder

I found one example on stephen lebans site
http://www.lebans.com/callbackbrowser.htm
but it required the code to exist in the code behind the form.
I use this on about 10 forms so would prefer something that I could place in
just one module.

Does anyone have a better solution?
Thanks in advance,
Mark

--------------------------------
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
Private Const BIF_NEWDIALOGSTYLE = &H40

Public Function BrowseFolder(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 + BIF_NEWDIALOGSTYLE
End With

dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
----------------------------------------
 
Mark Andrews said:
I am using this code to browse for a folder (just folders no files) in
Access 2007.
It works great, I just want one extra feature:
- to supply a starting folder

I found one example on stephen lebans site
http://www.lebans.com/callbackbrowser.htm
but it required the code to exist in the code behind the form.
I use this on about 10 forms so would prefer something that I could place
in
just one module.
Click to expand...

Put it this way. If Stephen couldn't make it work with the code in a single
common module, it can't be done.
 
Hi Mark
I have been using this function for a long time. Think it did start from
someone else but I have tweaked it over the years. Basically you pass the
form name and an optional starting path. It will return the file name. You
will have to tweak it to only return the folder, but that should not be too
hard.

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Hope this helps

'---------------------------------------------------------------------------------------
' Procedure : funBrowse
' Author : Neville Turbit
' Date : 04/06/09
' Purpose : Function to search all files
'---------------------------------------------------------------------------------------
'
Function funBrowse(strform As Form, Optional strPath As String) As String

On Error GoTo Error_funBrowse

Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String

OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = strform.hWnd

' Don't filter the files
sFilter = "All Files (*.*)" & Chr(0) & "*.*" '& Chr(0) & _
"JPEG Files (*.JPG)" & Chr(0) & "*.JPG" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1

OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile

' Set the initial directory
If IsNull(strPath) Then
OpenFile.lpstrInitialDir = "C:\"
Else
OpenFile.lpstrInitialDir = strPath
End If

OpenFile.lpstrTitle = "Select a file using the Common Dialog DLL"
OpenFile.flags = 0

lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
MsgBox "A file was not selected!", vbInformation, _
"Select a file using the Common Dialog DLL"
Else
funBrowse = Trim(Left(OpenFile.lpstrFile, InStr(1,
OpenFile.lpstrFile, vbNullChar) - 1))
End If

Exit_funBrowse:
On Error GoTo 0
Exit Function

Error_funBrowse:

MsgBox "An unexpected situation arose in your program." & funCrLf & _
"Please write down the following details:" & funCrLf & funCrLf & _
"Module Name: modGeneric" & funCrLf & _
"Type: Module" & funCrLf & _
"Calling Procedure: funBrowse" & funCrLf & _
"Error Number: " & Err.Number & funCrLf & _
"Error Descritption: " & Err.Description

Resume Exit_funBrowse
End Function
 
Yea I think you are right.
Mark

Douglas J. Steele said:
Put it this way. If Stephen couldn't make it work with the code in a
single common module, it can't be done.
Click to expand...
 
Mark Andrews said:
Thanks, however that's what I am using right now.
Mark
Click to expand...

Hi Mark

Unfortunately the browse folder dialog code wasn't written with VBA in mind.
You have to use a callback function in order to get the dialog to display
the initial folder selection. If anything causes VBA to go into break mode
while this is executing, Access will probably crash. That said, here is the
code you need. Create a class module (call it clsBrowseFolder) and paste in
the following:

''' Start 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 SHGetPathFromIDListA Lib "shell32.dll" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolderA Lib "shell32.dll" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Sub CopyMemory 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 Const LPTR = (&H0 Or &H40)
'
Private m_Caption As String
Private m_InitDir As String
Private m_ReturnDir As String
Private m_UserCancel As Boolean
Private m_hWndOwner As Long
Private m_ErrOption As Long

Public Property Get Caption() As String
Caption = m_Caption
End Property
Public Property Let Caption(NewData As String)
If Len(NewData) > 50 Then
Err.Raise vbObjectError + 1, _
"clsFolderDialog.Caption", _
"Caption too long. 50 chars max."
End If
m_Caption = NewData
End Property

Public Property Let InitDir(NewData As String)
m_InitDir = NewData
End Property

Public Property Get ReturnDir() As String
ReturnDir = m_ReturnDir
End Property

Public Property Get UserCancel() As Boolean
UserCancel = m_UserCancel
End Property

Public Property Let hWndOwner(NewData As Long)
m_hWndOwner = NewData
End Property

Public Sub Execute()
Dim bi As BROWSEINFO
Dim Buffer As String
Dim PathPtr As Long
Dim itemID As Long
'
With bi
.hOwner = m_hWndOwner
.ulFlags = 1
.lpszTitle = m_Caption
.lpfn = FuncPtr(AddressOf BrowseFolderHookProc)
PathPtr = LocalAlloc(LPTR, Len(m_InitDir) + 1)
CopyMemory ByVal PathPtr, ByVal m_InitDir, Len(m_InitDir) + 1
.lParam = PathPtr
End With
Buffer = Space$(512)
itemID = SHBrowseForFolderA(bi)
If SHGetPathFromIDListA(itemID, Buffer) Then
m_ReturnDir = Left(Buffer, InStr(Buffer, vbNullChar) - 1)
Else
m_UserCancel = True
End If
CoTaskMemFree itemID
LocalFree PathPtr
End Sub

Private Sub Class_Initialize()
m_Caption = "Please Select Folder"
With Application
m_hWndOwner = .hWndAccessApp
m_ErrOption = .GetOption("Error Trapping")
.SetOption "Error Trapping", 2
End With
End Sub

Private Sub Class_Terminate()
On Error Resume Next
Application.SetOption "Error Trapping", m_ErrOption
End Sub

Private Function FuncPtr(pFunc As Long) As Long
FuncPtr = pFunc
End Function
''' End Code '''

Then create a standard module (call it modBrowseFolder) and paste in the
following:

''' Start Code '''
Option Compare Database
Option Explicit
'
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 Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

Public Function BrowseFolderHookProc(ByVal hWnd As Long, ByVal uMsg As Long,
_
ByVal lParam As Long, ByVal lpData As Long) As Long
If uMsg = 1 Then
Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal lpData)
End If
End Function
''' End Code '''

A simple test:

With New clsBrowseFolder
.hwndOwner = Application.hWndAccessApp
.InitDir = "c:\temp"
.Execute
If Not .UserCancel Then
MsgBox "Selected Folder: " & .ReturnDir
End If
End With

Hope that helps.
 
' I don't know where I got this...
' Requires a reference to 'Microsoft Shell Controls and Automation'.
Sub TestIt()

MsgBox GetFolderPath("C:\Documents and Settings")

End Sub


Function GetFolderPath(Optional vntOpenAt As Variant) As String
Dim Shell As New Shell32.Shell
Dim Folder As Shell32.Folder
Dim FolderItem As Shell32.FolderItem

Set Folder = Shell.BrowseForFolder(0, "Please choose a folder", 0,
vntOpenAt)

If Not Folder Is Nothing Then
Set FolderItem = Folder.Self
GetFolderPath = FolderItem.Path
End If

End Function
 
Thanks but I don't want the reference in the mix. I thought the filedialog
was more similar to the common dialog to browse for files?

This is a folder ONLY search (no files are shown).

Mark
 
Yea I needed the Make New Folder, but I did start with the exact article you
mentioned.

Mark
 
Stuart,

This code works great! I did change the ulFlags (just to get the "make new
folder" button):
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_NEWDIALOGSTYLE = &H40

.ulFlags = BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE
'old way .ulFlags = 1

Thanks for this great help (A+),
Mark
 
I was going to use the code Stuart McCall suggested, but you might be right
and just using filedialog would be better.

The fileDialog does require a reference to Microsoft Office 12 Object
Library, but I think I always need that reference anyway
for the ribbon to work.

If anyone can see a problem with this method let me know.

Thanks for your help (I guess I had it in my mind that filedialog should not
be used over these other API calls),
Mark
 
Mark Andrews said:
Stuart,

This code works great! I did change the ulFlags (just to get the "make
new folder" button):
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_NEWDIALOGSTYLE = &H40

.ulFlags = BIF_RETURNONLYFSDIRS + BIF_NEWDIALOGSTYLE
'old way .ulFlags = 1

Thanks for this great help (A+),
Mark
Click to expand...

You're welcome (whether you decide to use it or not).

FWIW the reason I've stuck with the api is that I work in both Access and
vb6, and with a small change (which I removed to avoid confusion) it will
compile for either.
 
Mark Andrews said:
I was going to use the code Stuart McCall suggested, but you might be right
and just using filedialog would be better.

The fileDialog does require a reference to Microsoft Office 12 Object
Library, but I think I always need that reference anyway
for the ribbon to work.
Click to expand...

You can use FileDialog without a library reference, declaring everything as
Object to use late binding. However, you need to supply your own constants
for the ones defined in the object library, such as
msoFileDialogFolderPicker.
 
Back
Top