用BrowseForFolder 和 GetOpenFilename 选取文件夹和文件名称

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