用API打开“浏览文件夹”选择框的问题。请高手帮忙！

[MikeFuns]

怎样得到“浏览文件夹”这种功能的按钮，点击后弹出文件夹选择路径。
关键是如果上次已经打开某个文件夹了，第二次使用时怎么样一点击按钮就能显示出上次打开文件夹所在位置的那样的树状结构？

[留下些什么]

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

[MikeFuns]

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

[cuilonggang]

下面是模块代码，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

[viena]

'新建一个模块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中就保存了所选的文件夹

[viena]

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

[hpygzhx520]

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