Using VBA code to call the Browse folder dialog box

 

1. Use APIs

'[Type Declaration]
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
'[API Declaration]
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 Function lstrcat Lib "kernel32 "_
Alias "lstrcatA" (ByVal lpString1 As String ,_
ByVal lpString2 As String) As Long
Private Declare Function OleInitialize Lib "ole32.dll "_
(Lp As Any) As Long
Private Declare Sub OleUninitialize Lib "ole32 "()

Private Const BIF_USENEWUI = & H40
Private Const max_path= 260
'[Custom function]
Public Function GetFolder_API (sTitle As String, Optional vFlags As Variant) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim BInfo As BROWSEINFO

If IsMissing (vFlags) Then vFlags = BIF_USENEWUI

Call OleInitialize (ByVal 0 &)

With BInfo
. LpszTitle = lstrcat (sTitle ,"")
. UlFlags = vFlags
End

LpIDList = SHBrowseForFolder (BInfo)

If (lpIDList) Then
SBuffer = Space (MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
SBuffer = Left (sBuffer, InStr (sBuffer, vbNullChar)-1)

If sBuffer <> "Then GetFolder_API = sBuffer
End If

Call OleUninitialize
End Function
'[Usage]
Sub Test ()
MsgBox GetFolder_API ("select folder ")
End Sub

2. Use the Shell. Application Method

Sub GetFloder_Shell ()

Set objShell = CreateObject ("Shell. Application ")
Set objFolder = objShell. BrowseForFolder (0, "select folder", 0, 0)
If Not objFolder Is Nothing Then
MsgBox objFolder. self. path
End If
Set objFolder = Nothing
Set objShell = Nothing

End Sub

3. Use the filedialog Method

Sub getfloder_filedialog ()
Dim FD as filedialog
Set FD = application. filedialog (msofiledialogfolderpicker)
If FD. Show =-1 then msgbox FD. selecteditems (1)
Set FD = nothing
End sub

The above method passed the test in WINXP + office2003

 

Bytes ----------------------------------------------------------------------------------------------------------

URL: http://www.officexy.com/Articles/office/VBABasic/20061026103436069.htm