这是精品代码，方便好用，可乐谷经常使用，强列推荐

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝ 此行开始加入BAS模块中＝＝＝＝＝＝＝＝＝＝
Option Explicit '此行开始加入BAS模块中
Public 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 TypePublic Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPublic Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As LongPublic Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

Public Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long

Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long

Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long

Public Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long

Public Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Public Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long

Select Case uMsg
Case BFFM_INITIALIZED

Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal StrFromPtrA(lpData))

Case Else:

End Select

End Function

Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long

Select Case uMsg
Case BFFM_INITIALIZED

Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)

Case Else:

End Select

End Function

Public Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function

Public Function StrFromPtrA(lpszA As Long) As String
Dim sRtn As String
sRtn = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal sRtn, ByVal lpszA)
StrFromPtrA = sRtn
End Function '加入模声内容结束

'＝＝＝＝＝＝＝＝＝＝＝＝＝加入模块内容结束＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

'======================将下面代码加入窗体。窗体上还应放置三个按钮和两个TextBox。
Option ExplicitPrivate Sub cmdString_Click()
Text2 = ""
Text2 = BrowseForFolderByPath((Text1))
End SubPrivate Sub cmdPIDL_Click()
Text2 = ""
Text2 = BrowseForFolderByPIDL((Text1))
End SubPrivate Sub cmdEnd_Click()
Unload Me
End Sub

Public Function BrowseForFolderByPath(sSelPath As String) As String

Dim BI As BROWSEINFO
Dim pidl As Long
Dim lpSelPath As Long
Dim sPath As String * MAX_PATH

With BI
.hOwner = Me.hWnd
.pidlRoot = 0
.lpszTitle = "Pre-selecting the folder using the folder's string."
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)

lpSelPath = LocalAlloc(LPTR, Len(sSelPath))
MoveMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
.lParam = lpSelPath

End With

pidl = SHBrowseForFolder(BI)

If pidl Then

If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If

Call CoTaskMemFree(pidl)

End If

Call LocalFree(lpSelPath)

End Function

Public Function BrowseForFolderByPIDL(sSelPath As String) As String

Dim BI As BROWSEINFO
Dim pidl As Long
Dim sPath As String * MAX_PATH

With BI
.hOwner = Me.hWnd
.pidlRoot = 0
.lpszTitle = "Pre-selecting a folder using the folder's pidl."
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
.lParam = SHSimpleIDListFromPath(sSelPath)
End With

pidl = SHBrowseForFolder(BI)

If pidl Then
If SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If

Call CoTaskMemFree(pidl)
End If

Call CoTaskMemFree(BI.lParam)
End Function
'==============================主体结束＝＝＝＝＝＝＝＝＝＝＝＝