搜了一下网上，以下代码可以使用于VB6和VBA（2003），但是它只能选择一个文件夹，
能同时选择多个文件夹的则还没有查到，各位高手是否做一个，本人的确需要，谢谢。
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)
  MsgBox "您选择的文件夹：" & Text1
Else: Text1 = ""
End If
End Sub

如此做法，好像是不能像一楼的代码那样自主地选择文件夹的。

本人很菜，请帮忙做个附件如何？谢谢。

如图

1楼的要求就是选择4楼的图片的”d:\“以下一个或多个文件夹（同一级目录）。

谢谢版主。已按您的要求去做，没做好。附件没法上传，不知何因。
不要误解7楼和8楼的意思。7楼和8楼的说明是个例，
文件夹的展开应象1楼一样，即人工点击后，可展开下一级文件夹。

[此贴子已经被作者于2016-5-11 11:17编辑过]

谢谢。
不要误解7楼和8楼的意思。7楼和8楼的说明是个例，
文件夹的展开应象1楼一样，即人工点击后，可展开下一级文件夹，而且根目录应由使用者自主选择才是。

[此贴子已经被作者于2016-5-11 16:48编辑过]