Option Explicit
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
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 Const BIF_RETURNONLYFSDIRS = &H1
'只能选择文件夹
Private Const BIF_USENEWUI = &H40
'对话框上有“新建文件夹”按钮
Private Const MAX_PATH = 260
'路径最大值
Private Type BROWSEINFO
hOwner As Long
'主句柄
pidlRoot As Long
'展开根目录
pszDisplayName As String
lpszTitle As String
''列表框标题,这里是用的long,所以得用lstrcat获取字符指针了
ulFlags As Long
'规定只能选择文件夹，其他无效
lpfn As Long
lParam As Long
iImage As Long
End Type
Public Function GetFolderPath(frmHwnd As Long) As String
Dim iNull As Integer, lpIDList As Long
Dim sPath As String, udtBI As BROWSEINFO
With udtBI
.hOwner = frmHwnd
'设置主窗体句柄
.lpszTitle = "请选择程序路径"
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI '问题在这行
End With
'显示列表框
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'获取返回的路径
SHGetPathFromIDList lpIDList, sPath
'释放内存块
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
'去除空格符
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
GetFolderPath = sPath
End Function
Private Sub Command1_Click()
Dim retFolderPath$
retFolderPath$ = GetFolderPath(Me.hWnd)
MsgBox IIf(retFolderPath$ <> vbNullString, "你选择了" & retFolderPath$, "你取消了选择"), vbInformation, "提示"
End Sub
问题出在代码中的红字粗体一行，如果写成.ulFlags = BIF_RETURNONLYFSDIRS，则该常数有效果；但是如果写成.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI，则BIF_USENEWUI常数有效，BIF_RETURNONLYFSDIRS常数就无效了，这是为什么？
我去MSDN上找过了，没见到写的这么细致的，着急中……
[
本帖最后由 VBhere 于 2010-3-17 16:13 编辑 ]
