Just paste this source code into a module called basFolders and include it in your project.
'----------------------------------------------------------------------
'
' Class Name: basFolders
' Written By: C&D Programming Corp.
' Create Date: 6/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit
Private Const MAX_PATH = 260
' BIF_RETURNONLYFSDIRS Only return file system directories. If the
' user selects folders that are not part of the
' file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1 ' For finding a folder to start document searching
Private Declare Function SHBrowseForFolder _
Lib "shell32" _
(lpBrowseInfo As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList _
Lib "shell32" _
(ByVal pidList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function lstrcat _
Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal _
lpString2 As String) As Long
'
' Data structure that SHBrowseForFolder requires
'
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Public Function BrowseFolders(frmParent As Form, Optional sTitle As String) As String
Dim lIDList As Long
Dim sBuffer As String
Dim tBrowseInfo As BrowseInfo
On Error Goto Handler
With tBrowseInfo
.hWndOwner = frmParent.hWnd ' set the parent window
.lpszTitle = lstrcat(sTitle, "") ' create title
.ulFlags = BIF_RETURNONLYFSDIRS ' only get standard file systems (not printers)
End With
lIDList = SHBrowseForFolder(tBrowseInfo) ' show dialog box
' retrieve the directory selected.
If (lIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseFolders = sBuffer
Else
BrowseFolders = ""
End If
Exit Function
Handler:
Err.Raise Err.Number, "BrowseFolders", Err.Description
End Function