怎样弹出打开文件夹对话框？

[hfrui]

怎样弹出打开文件夹对话框？

[xxlroad]

Option Explicit
' form 中 一个cmdLocation command和一个txtPath text

'程序如下:
Private Sub cmdLocation_Click() '为 command
Dim LocDir As BROWSEINFO
Dim RetVal As Boolean, PidLoc As Long
Dim Path As String
Dim Pos As Integer
LocDir.hOwner = Me.hWnd
LocDir.lpszTitle = "请选择一个目录："
LocDir.ulFlags = BIF_RETURNONLYFSDIRS
'PidLoc是一个返回值，指向用户定位的目录对应的ID，还不是目录
PidLoc = SHBrowseForFolder(LocDir)
Path = Space(512)
'用SHGetPathFromIDList()API把PidLoc对应的ID转换成对应的目录
RetVal = SHGetPathFromIDList(ByVal PidLoc, ByVal Path)
If RetVal Then
'去掉后面多余的ASCII码为0的字符
Pos = InStr(Path, Chr$(0))
'txtPath就是要求输入路径的那个文本框
txtPath.Text = Left(Path, Pos - 1)
txtPath.SetFocus
End If
End Sub

' bas 中
Option Explicit

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

'可见只有一个参数BROWSEINFO，这是一个类型，定义如下：
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

'hOwner是父窗口的hWnd
'lpszTitle是显示在该窗口上方的提示文字标题
'ulFlags是设置显示的是什么类型，这里设置为显示文件目录系统
'pidlRoot为NULL（不设置任何值的时候）表示从桌面开始显示，即显示所有磁盘，包括网上邻居……
'PidLoc是返回值，表示用户选择的目录对应的ID
'这个ID还要用SHGetPathFromIDList()API转换为对应的目录才能用

'SHGetPathFromIDList()API的申明如下：
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

'另外还要申明一些常量，用于ulFlags的设置：
Public Const BIF_RETURNONLYFSDIRS = &H1 '<---我用的是这个，显示所有磁盘……
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
'

[mickwang]

添加一个CommonDialog控件

CommonDialog1.ShowOpen

[Sean918]

如楼上的，最简单。

添加一个CommonDialog控件

CommonDialog1.ShowOpen

[lvjack]

直接把以下代码存成form1.frm就能用了



VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 1485
ClientLeft = 60
ClientTop = 345
ClientWidth = 3600
LinkTopic = "Form1"
ScaleHeight = 1485
ScaleWidth = 3600
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "浏览"
Height = 375
Left = 1080
TabIndex = 0
Top = 480
Width = 1215
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'这个程序演示利用Shell API函数弹出文件夹浏览窗口
'
'作者 陈锐
'EMail [e-mail]
' [e-mail]
'WebSite http://vbtip.syeah.net

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

Private Declare Function SHGetSpecialFolderLocation Lib _
"shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _
As Long, pIdl As ITEMIDLIST) As Long

Private Declare Function SHGetFileInfo Lib "Shell32" Alias _
"SHGetFileInfoA" (ByVal pszPath As Any, ByVal _
dwFileAttributes As Long, psfi As SHFILEINFO, ByVal _
cbFileInfo As Long, ByVal uFlags As Long) As Long

Private Declare Function ShellAbout Lib "shell32.dll" Alias _
"ShellAboutA" (ByVal hwnd As Long, ByVal szApp As _
String, ByVal szOtherStuff As String, ByVal hIcon As Long) _
As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal _
pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Const MAX_PATH = 260

Private Type SHITEMID
cb As Long
abID() As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

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 Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Function GetFolderValue(wIdx As Integer) As Long
If wIdx < 2 Then
GetFolderValue = 0
ElseIf wIdx < 12 Then
GetFolderValue = wIdx
Else
GetFolderValue = wIdx + 4
End If
End Function

Private Sub Command1_Click()
Dim BI As BROWSEINFO
Dim nFolder As Long
Dim IDL As ITEMIDLIST
Dim pIdl As Long
Dim sPath As String
Dim SHFI As SHFILEINFO
Dim m_wCurOptIdx As Integer
Dim txtPath As String
Dim txtDisplayName As String

With BI
.hOwner = Me.hwnd
nFolder = GetFolderValue(m_wCurOptIdx)

If SHGetSpecialFolderLocation(ByVal Me.hwnd, ByVal nFolder, IDL) = NOERROR Then
.pidlRoot = IDL.mkid.cb
End If

.pszDisplayName = String$(MAX_PATH, 0)
.lpszTitle = "Browsing is limited to: "
.ulFlags = 0
End With

txtPath = ""
txtDisplayName = ""

pIdl = SHBrowseForFolder(BI)

If pIdl = 0 Then Exit Sub
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList ByVal pIdl, ByVal sPath

txtPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
txtDisplayName = Left$(BI.pszDisplayName, _
InStr(BI.pszDisplayName, vbNullChar) - 1)

SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), _
SHGFI_PIDL Or SHGFI_ICON Or SHGFI_SMALLICON

SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), _
SHGFI_PIDL Or SHGFI_ICON
CoTaskMemFree pIdl
MsgBox "你选择的文件夹是" + Chr(13) + Chr(10) + txtPath
End Sub