End Sub'bas中 Option ExplicitPublic 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
不用控件使用API函数: 'SHBrowseForFolder函数参数设定 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 SHITEMID cb As Long abID As Byte End Type
Private Type ITEMIDLIST mkid As SHITEMID End Type Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) 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 SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLISTPrivate Sub Command1_Click() Dim MyFolder As String Dim intNull As Integer Dim strPath As String Dim bi As BROWSEINFO Dim idl As ITEMIDLIST Dim rtn&, pidl&, path$, pos% nFolder& = 17
'大于零表示路径存在 If intNull > 0 Then '取路径 strPath = Left(path, intNull - 1) End If If strPath <> Empty Then If Right(strPath, 1) <> "\" Then '返回路径名子 MyFolder = strPath & "\" Else MyFolder = strPath End If
'在文本框显示路径 Text1.Text = MyFolder Else Text1.Text = Text1.Text End If
Commanddialog.ShowOpen方法
Option Explicit
'程序如下:
Private Sub cmdLocation_Click()
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 = Left(Path, Pos - 1) txtPath.SetFocus
End If
End Sub'bas中
Option ExplicitPublic 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
http://ygyuan.3322.net/有源代码,可以预设默认目录.
'SHBrowseForFolder函数参数设定
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 SHITEMID
cb As Long
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) 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 SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long 'ITEMIDLISTPrivate Sub Command1_Click()
Dim MyFolder As String
Dim intNull As Integer
Dim strPath As String
Dim bi As BROWSEINFO
Dim idl As ITEMIDLIST
Dim rtn&, pidl&, path$, pos%
nFolder& = 17
'句柄为窗体句柄
bi.hOwner = Me.hWnd
'调用SHGetSpecialFolderLocation函数,设定浏览本机文件夹
rtn& = SHGetSpecialFolderLocation(ByVal Me.hWnd, ByVal nFolder&, idl)
bi.pidlRoot = idl.mkid.cb
'设定文件夹返回类型
bi.ulFlags = BIF_RETURNONLYFSDIRS
'设定浏览标题
bi.lpszTitle = "浏览文件夹"
'显示浏览文件夹对话框
pidl& = SHBrowseForFolder(bi)
'得到选择的文件夹
path$ = Space$(512)
rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$)
intNull = InStr(path, vbNullChar)
'大于零表示路径存在
If intNull > 0 Then
'取路径
strPath = Left(path, intNull - 1)
End If If strPath <> Empty Then
If Right(strPath, 1) <> "\" Then
'返回路径名子
MyFolder = strPath & "\"
Else
MyFolder = strPath
End If
'在文本框显示路径
Text1.Text = MyFolder
Else
Text1.Text = Text1.Text
End If
End Sub