Attribute VB_Name = "选取文件夹和文件名称"
'需引用 Microsoft Shell Controls and Automation
'定位与 c:/windows/system32/SHELL32.DLL
'BrowseForFolder (Hwnd, Title, Options, [RootFolder])
'Hwnd:包含对话框的窗体句柄(handle),一般设置为0。
'Title:将在对话框中显示的说明,为字符串。
'Options:使用对话框的特殊方式,为长整数,一般设置为0。
' 0-15表示一般的对话框,16-31为有显示当前文件夹文本框的对话框,如有的显示滚动条,有的则没有。
' 0x0001 For finding a folder to start document searching
' 0x0002 For starting the Find Computer
' 0x0004 对话框加宽
' 0x0008 确定按钮变灰失效
' 0x0010 在对话框顶部加入编辑框
' 0x0020 insist on valid result (or CANCEL)
' 0x0100 对话框显示提示文字
' 0x0200 不显示 新建文件夹 按钮
' 0x1000 确定按钮变灰失效
' 0x2000 可选当前文件,不包括子目录文件,确定按钮变灰失效,(可同时选0x0001使确定按钮有效)
' 0x4000 浏览所有项,可选文件或文件夹
' 负数 会显示特殊的浏览对话框
'[RootFolder]:可选的,用来设置浏览的最顶层文件夹,缺省时为“桌面”,你可以将其设置为一个路径或“特殊文件夹常数”。
' 0x0000 桌面
' 0x0001 IE浏览器
' 0x0002 C:/WINDOWS/StartMenu/Programs目录
' 0x0003 控制面板
' 0x0004 打印机
' 0x0005 我的文档
' 0x0006 收藏
' 0x0007 启动
' 0x0008 Recent
' 0x0009 发送到
' 0x000a 回收站
' 0x000b 开始菜单
' 0x000c 桌面(打开在我的电脑)
' 0x0010 C:/WINDOWS/Desktop桌面目录
' 0x0011 我的电脑(包括所有驱动器)
' 0x0012 整个网络
' 0x0013 NetHood
' 0x0014 字体目录
' 0x0015 C:/WINDOWS/ShellNew目录
' 0x001a C:/WINDOWS/Application Data目录
' 0x001b printHood
' 0x0020 C:/WINDOWS/Temporary Internet Files目录
' 0x0021 cookie目录
' 0x0022 IE浏览历史
'选取文件夹名称
Public Function ChooseDirectoryOnly(ByRef strTitle As String) As String
Dim shApp As Object, mPath As Object
strTitle = "请选择" & strTitle & "文件夹"
Set shApp = CreateObject("Shell.application")
Set mPath = shApp.BrowseForFolder(0, strTitle, 0, &H11) '顶层目录为“我的电脑”
If mPath Is Nothing Then
ChooseDirectoryOnly = ""
Else
ChooseDirectoryOnly = IIf(IsError(mPath.items.Item.Path), mPath.Title, mPath.items.Item.Path)
End If
'mPath.Items.Verbs集合中有此文件夹右键的菜单
If Not (mPath Is Nothing) Then Set mPath = Nothing
Set shApp = Nothing
End Function
'下面函数在Excel中有效
'选取一个文件
Public Function ChooseOneFile(ByRef strTitle As String) As String
Dim FileName As Variant
On Error Resume Next
FileName = Application.GetOpenFilename(FileFilter:=strTitle & "所有文件(*.*),*.*", Title:="选择" & strTitle & "文件", MultiSelect:=False)
ChooseOneFile = IIf(FileName = False, "", FileName)
End Function
'下面过程在Excel中有效
'选取多个文件
Public Sub ChooseMultiFiles(ByRef strTitle As String)
Dim hFile As Integer
Dim FileName As Variant
On Error Resume Next
FileName = Application.GetOpenFilename(FileFilter:=strTitle & "所有文件(*.*),*.*", Title:="选择" & strTitle & "文件", MultiSelect:=True)
If Not IsArray(FileName) Then Exit Sub
For Each strOpenFile In FileName
Open strOpenFile For Input As hFile
Do While Not EOF(1)
'
'
'
Loop
Close #hFile
Next strOpenFile
End Sub