VB/VBAͨÓ÷¾¶Ñ¡Ôñ¶Ô»°¿ò

Option Explicit
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pDisplayName As String
lpTitle 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 pPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

Private Const BIF_RETURNONLYFSDIRS = &H1
' *******************************************************************
' º¯ÊýÃû: BrowseFolder
' ¹¦ÄÜ: ä¯ÀÀ¼°Ñ¡ÔñÎļþ¼ÐͨÓöԻ°¿ò
' ʹÓ÷½·¨:£¨1£©½«mdlBrowseFolder.basÄ£¿éÌí¼Óµ½µ±Ç°¹¤³ÌÖÐ;
' (2£©ÔÚµ±Ç°¹¤³ÌÖÐʹÓÃ
' dim strMyPath as String
' strMyPath=BrowseFolder("ÇëÑ¡ÔñĿ¼")
' ´úÂë¶Î½øÐе÷Óã¬Óû§Ñ¡ÔñµÄĿ¼½«±£´æÔÚstrPath×Ö·û´®±äÁ¿ÏÂ;
' (3) Èç¹ûÓû§Ñ¡Ôñ"È¡Ïû"°´Å¥,ÔòstrPathµÄֵΪ¿Õ;
' *******************************************************************
Public Function BrowseFolder(strDialogTitle As String) As String
Dim X As Long
Dim bi As BROWSEINFO
Dim dwIList As Long
Dim strPath As String
Dim wPos As Integer

With bi
.hOwner = 0& 'hWndAccessApp
.lpTitle = strDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With

dwIList = SHBrowseForFolder(bi)
strPath = Space$(512)
X = SHGetPathfromIDList(ByVal dwIList, ByVal strPath)

If X Then
wPos = InStr(strPath, Chr(0))
BrowseFolder = Left$(strPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If

' È·±£·µ»ØµÄ·¾¶×Ö·û´®µÄ×îºóÒ»¸ö×Ö·ûΪ"\"
If BrowseFolder <> "" And Right(Trim(BrowseFolder), 1) <> "\" Then
BrowseFolder = BrowseFolder & "\"
End If

End Function
' ²âÊÔʾÀý
Sub Main