如何让用户选择目录？

[gqzhang]

vb里面有个commondialog可以让用户查找具体的文件，请问如何指定一个目录，有控件可以实现吗？
可以不使用Driverlistbox和Dirlistbox吗？还是要用它们？
谢谢

[online]

Option Explicit

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

Const BIF_RETURNONLYFSDIRS = &H1

Private pidl As Long

Private Declare Function SHGetPathFromIDList _
Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

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


'　　 双击命令按钮，写如下代码：

Private Sub command1_Click()
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer

'句柄
bi.hOwner = Me.hWnd

'展开根目录
bi.pidlRoot = 0&

'列表框标题
bi.lpszTitle = "请选择软件安装路径："
'规定只能选择文件夹，其他无效

bi.ulFlags = BIF_RETURNONLYFSDIRS

'调用API函数显示列表框

pidl = SHBrowseForFolder(bi)

'利用API函数获取返回的路径


path = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
Text1 = Left(path, pos - 1)
Else: Text1 = ""
End If
End Sub

[gqzhang]

......谢谢
其实我只是想问问有没有控件设置一下就可以实现?
不过还是很感谢！

[dongge2000]

和楼上是一个方法，写成函数方便一点，非原著！
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

[lfshf]

放模块：

'Directory browsing functions
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


'Display "Browse for folder" window with message header
Public Function GetBrowseDir(ThaForm As Long, Msg As String) As String
GetBrowseDir = vbGetBrowseDirectory(ThaForm, Msg)
End Function
Public Function vbGetBrowseDirectory(ThaForm As Long, Msg As String) As String

Dim bi As BROWSEINFO


Dim R As Long
Dim pidl As Long
Dim tmpPath As String
Dim pos As Integer

bi.hOwner = ThaForm
bi.pidlRoot = 0&
bi.lpszTitle = Msg
bi.ulFlags = BIF_RETURNONLYFSDIRS

'get the folder
pidl& = SHBrowseForFolder(bi)

tmpPath$ = Space$(512)
R& = SHGetPathFromIDList(ByVal pidl&, ByVal tmpPath$)

If R& Then
pos% = InStr(tmpPath$, Chr$(0))
tmpPath$ = Left(tmpPath$, pos - 1)
vbGetBrowseDirectory = tmpPath$
Else
vbGetBrowseDirectory = ""
End If

End Function

调用
Public Sub GetFolder()
Dim sFolder As String

sFolder = GetBrowseDir(Me.hwnd, "请选择目标目录:")

End Sub

[creazyfish]

这个没有控件可以实现的，只能同过api
在模块中可以这么写
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 Type

Const BIF_RETURNONLYFSDIRS = &H1

Public pidl As Long

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

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

在窗体调用的地方写
Private Sub cmd_Click()
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer
'句柄
bi.hOwner = Me.hWnd
'展开根目录
bi.pidlRoot = 0&
'列表框标题
bi.lpszTitle = "请选择源文件夹路径："
'规定只能选择文件夹，其他无效
bi.ulFlags = BIF_RETURNONLYFSDIRS
'调用API函数显示列表框
pidl = SHBrowseForFolder(bi)
'利用API函数获取返回的路径
path = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal path)

If r Then
pos = InStr(path, Chr$(0))
txtFile.Text = Left(path, pos - 1)
Else
txtFile.Text = ""
End If

End Sub

[gqzhang]

多谢各位帮忙！