Option Explicit

Public Type BROWSEINFOTYPE
    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

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFOTYPE As BROWSEINFOTYPE) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
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
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Public Const WM_USER = &H400

Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
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 Const LPTR = (&H0 Or &H40)

Public Function BrowseCallbackProcStr(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

Public Function FunctionPointer(FunctionAddress As Long) As Long
FunctionPointer = FunctionAddress
End Function

Public Function BrowseForFolder(hWnd As Long, strTitle As String, selectedPath As String) As String
Dim Browse_for_folder As BROWSEINFOTYPE
Dim itemID As Long
Dim selectedPathPointer As Long
Dim tmpPath As String * 256

If Not Right$(selectedPath, 1) <> "\" Then
    selectedPath = Left$(selectedPath, Len(selectedPath) - 1) ' 如果用户加了 "\" 则删除
End If

With Browse_for_folder
    .hOwner = hWnd ' 所有都窗口之句柄
    .lpszTitle = strTitle ' 对话框的标题
    .lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr) '用于设置预设文件夹的回调函数
    selectedPathPointer = LocalAlloc(LPTR, Len(selectedPath) + 1) ' 分配一个字符串内存
    CopyMemory ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1 ' 拷贝那个路径到内存
    .lParam = selectedPathPointer ' 预设的文件夹
End With
itemID = SHBrowseForFolder(Browse_for_folder) ' 执行API函数： BrowseForFolder
If itemID Then
    If SHGetPathFromIDList(itemID, tmpPath) Then '取得选定的文件夹
        BrowseForFolder = Left$(tmpPath, InStr(tmpPath, vbNullChar) - 1) '去掉多余的 null 字符
    End If
    Call CoTaskMemFree(itemID) '释放内存
End If
Call LocalFree(selectedPathPointer) ''释放内存
End Function

谁能给一个可运行的程序代码段，谢谢了。
一运行到  call CopyMemory (ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1 )  程序就死掉了.

下面是模块代码，GetFolder函数可指定开始的目录，你可以稍加修改，在模块内或在外部保存上次的目录，为指定目录时使用上次的目录。
Option Explicit

''''''''For GetFolder()'''''''''
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (LpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
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 Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public 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
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 Const BIF_RETURNONLYFSDIRS = 1
Private Const LMEM_ZEROINIT = &H40
Public Const BFFM_INITIALIZED = 1
Public Const WM_USER = &H400
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)

'''''''''''''''用于GetFolder
Private Function MyAddressOf(AddressOfX As Long) As Long
    MyAddressOf = AddressOfX
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
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 GetFolder(ByVal hwnd As Long, Optional StartDir As String, Optional Title As String) As String

    Dim BI As BROWSEINFO
    Dim pidl As Long, Ret As Long
    Dim folder As String
    
    folder = Space(255)
    With BI
        If IsNumeric(hwnd) Then .hOwner = hwnd
        .ulFlags = BIF_RETURNONLYFSDIRS
        .pidlroot = 0
        If Title <> "" Then
            .lpszTitle = Title & Chr$(0)
        Else
            .lpszTitle = "选择目录" & Chr$(0)
        End If
        .lpfn = MyAddressOf(AddressOf BrowseCallbackProcStr)
        If Not IsMissing(StartDir) Then
            Ret = LocalAlloc(ByVal LMEM_ZEROINIT, Len(StartDir))
            CopyMemory ByVal Ret, ByVal StartDir, Len(StartDir)
            .lParam = Ret
        End If
    End With
    
    pidl = SHBrowseForFolder(BI)
    If pidl Then
        If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
            GetFolder = Left(folder, InStr(folder, Chr$(0)) - 1)
        End If
        Call CoTaskMemFree(pidl)
    End If
    Call LocalFree(Ret)
End Function

'新建一个模块Module，复制如下代码到里面
Option Explicit

Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long
Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Dim xStartPath As String

Function SelectDir(Optional StartPath As String,Optional Titel As String) As String
    Dim iBROWSEINFO As BROWSEINFO
    With iBROWSEINFO
        .lpszTitle = IIf(Len(Titel), Titel, "【请选择文件夹】")
        .ulFlags = 7
        If Len(StartPath) Then
        xStartPath = StartPath & vbNullChar
        .lpfnCallback = GetAddressOf(AddressOf CallBack)
        End If
    End With
    Dim xPath As String, NoErr As Long: xPath = Space$(512)
    NoErr = SHGetPathFromIDList(SHBrowseForFolder(iBROWSEINFO), xPath)
    SelectDir = IIf(NoErr, Left$(xPath, InStr(xPath, Chr(0)) - 1), "")
End Function

Function GetAddressOf(Address As Long) As Long
    GetAddressOf = Address
End Function

Function CallBack(ByVal hWnd As Long, _
                  ByVal Msg As Long, _
                  ByVal pidl As Long, _
                  ByVal pData As Long) As Long
    Select Case Msg
        Case 1
            Call SendMessage(hWnd, 1126, 1, xStartPath)
        Case 2
            Dim sDir As String * 64, tmp As Long
            tmp = SHGetPathFromIDList(pidl, sDir)
            If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir
    End Select
End Function


'在窗体中：
dim strDir as String
strDir = SelectDir("C:\", "呵呵，请选择所需的文件夹")'假设初始路径为"C:\"
'strDir中就保存了所选的文件夹

保存上次打开的文件夹路径，作为初始路径(第一个参数)

Option Explicit
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi 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
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
Private Sub Command1_Click()
   Dim lpIDList As Long
   Dim sBuffer As String
   Dim szTitle As String
   Dim tBrowseInfo As BrowseInfo
   szTitle = "This is the title"
   With tBrowseInfo
        .hWndOwner = Me.hWnd
        .lpszTitle = lstrcat(szTitle, "")
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
   End With
   lpIDList = SHBrowseForFolder(tBrowseInfo)
   If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        MsgBox sBuffer
   End If
End Sub