VBA文件对话框的应用（VBA打开文件、VBA选择文件、VBA选择文件夹，VBA遍历文件夹)

在Scripting类库中有三个可以直接使用NEW关键字实例化的类，第一个就是常用的字典，第三个是FSO。

Dictionary

Encoder

FileSystemObject

一、FSO对象引用的方法:

 前期绑定：先要引用类库文件scrrun.dll，写代码的时候有智能提示。如果程序发给别人用，就要用后期绑定方式。

 Dim fso As New Scripting.FileSystemObject 

 后期绑定：不需要引用类库文件，但没有智能提示。

 Set fso = CreateObject('Scripting.FileSystemObject')

递归，提取文件名，office2019测试通过；

Sub ListFilesTest()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> '\' Then myPath = myPath & '\'
[a:b] = ''
Call ListAllFso(myPath, 1)
MsgBox 'OK'
End Sub
Function ListAllFso(myPath$, i)
Set Fld = CreateObject('Scripting.FileSystemObject').GetFolder(myPath)
For Each f In Fld.Files
    If f.Name Like '*.xls*' Then
        Cells(i, 2) = f.Name
        Cells(i, 1) = f.ParentFolder.path
        i = i + 1
    End If
Next
For Each fd In Fld.SubFolders
    Cells(i, 1) = fd.path
    i = i + 1
    Call ListAllFso(fd.path, i)
Next

End Function

 上面，根据使用略微调整

Sub ListFilesTest()
'With Application.FileDialog(msoFileDialogFolderPicker)
'If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
'End With
Dim ws As Worksheet
Set ws = Worksheets('File')
With ws
    rowmax = WorksheetFunction.Max(.Cells(65536, 1).End(xlUp).Row, .Cells(65536, 2).End(xlUp).Row)
    If rowmax > 4 Then .Range(.Cells(5, 1), .Cells(rowmax, 5)).ClearContents
End With
 myPath$ = Worksheets('Main').Cells(28, 4).Value
If Right(myPath, 1) <> '\' Then myPath = myPath & '\'
Call ListAllFso(myPath, 5, ws)
MsgBox 'OK'
End Sub
Function ListAllFso(myPath$, i, ws As Worksheet)
Set Fld = CreateObject('Scripting.FileSystemObject').GetFolder(myPath)
Set Fso = CreateObject('Scripting.FileSystemObject')
For Each f In Fld.Files
    If f.Name Like '*.xls*' Then
        ws.Cells(i, 1) = f.ParentFolder.path
        ws.Cells(i, 2) = Fso.GetBaseName(f.Name)
        ws.Cells(i, 3) = f.DateLastModified
        ws.Cells(i, 5) = Fso.GetExtensionName(f.Name)
        ws.Cells(i, 4) = f.Size
        i = i + 1
    End If
Next
For Each fd In Fld.SubFolders
'    ws.Cells(i, 1) = fd.path
'    i = i + 1
    Call ListAllFso(fd.path, i, ws)
Next

End Function

 文件改名，然后再重新载入；

Sub RenameFile()
Dim ws As Worksheet
Set ws = Worksheets('File')
Set Fso = CreateObject('Scripting.FileSystemObject')
With ws
    rowmax = WorksheetFunction.Max(.Cells(65536, 1).End(xlUp).Row, .Cells(65536, 2).End(xlUp).Row)
    If rowmax > 4 Then
        For i = 5 To rowmax
            If .Cells(i, 6) <> '' Then
                oldname = .Cells(i, 1) & '\' & .Cells(i, 2) & '.' & .Cells(i, 5)
                newname = .Cells(i, 1) & '\' & .Cells(i, 6) & '.' & .Cells(i, 5)
                If Fso.fileexists(newname) Then
                    MsgBox i & '行，以新文件名命名的文件已存在； ' & newname
                Else
                    On Error Resume Next
                    Name oldname As newname
                End If
ErrorProcess:
                If Err.Number = 58 Then
                    newname = .Cells(i, 1) & '\' & .Cells(i, 6) & '_' & i & '.' & .Cells(i, 5)
                    Name oldname As newname
                    Err.Clear
'                    MsgBox Err.Number
                End If
            Else
                MsgBox i & '行，无新文件名，未改名；'
            End If
        Next
    End If
    ws.Select
    ws.Cells(5, 2).Activate
End With
Call ListFiles
End Sub 

Sub 提取文件夹名称()

Dim fs As Object
n = 1
Set fs = CreateObject('Scripting.FileSystemObject')
Set f = fs.getfolder('D:\Personal\Downloads')
For Each fd In f.subfolders
Cells(n, 1) = fd.Name
n = n + 1
Next
Set f = Nothing
Set fs = Nothing
End Sub

如果想通过VBA代码由自己选择文件夹再执行提取文件夹名称，：

Sub getFldList1()
Dim Fso, Fld
Dim Arr(1 To 999), k%
Set Fso = CreateObject('Scripting.FileSystemObject')
Set Fld = Fso.getfolder(CreateObject('Shell.Application').BrowseForFolder(0, '请选择文件夹', 0, '').Self.Path & '')
For Each fd In Fld.subfolders
k = k + 1
Arr(k) = fd.Name
Next
[A1].Resize(k) = Application.Transpose(Arr)
End Sub

Sub 遍历文件夹()
'On Error Resume Next
Dim fn(1 To 10000) As String
Dim f, i, k, f2, f3, x
Dim arr1(1 To 100000, 1 To 1) As String, q As Integer
Dim t
t = Timer
fn(1) = ThisWorkbook.Path & '\'
i = 1: k = 1
Do While i < UBound(fn)
If fn(i) = '' Then Exit Do
f = Dir(fn(i), vbDirectory)
Do
If InStr(f, '.') = 0 And f <> '' Then
k = k + 1
fn(k) = fn(i) & f & '\'
End If
f = Dir
Loop Until f = ''
i = i + 1
Loop
'*******接下来是提取各个文件夹的文件***
For x = 1 To UBound(fn)
If fn(x) = '' Then Exit For
f3 = Dir(fn(x) & '*.*')
Do While f3 <> ''
q = q + 1
arr1(q, 1) = fn(x) & f3
f3 = Dir
Loop
Next x
ActiveSheet.UsedRange = ''
Range('a1').Resize(q) = arr1
MsgBox Format(Timer - t, '0.00000')
End Sub

在VBA中经常要用到文件对话框来进行打开文件、选择文件或选择文件夹的操作。
用Microsoft Office提供的文件对话框比较方便。
用法如下
Application.FileDialog(fileDialogType)
fileDialogType      MsoFileDialogType 类型，必需。文件对话框的类型。

　　　　MsoFileDialogType 可为以下 MsoFileDialogType 常量之一。
　　　　msoFileDialogFilePicker  允许用户选择文件。
　　　　msoFileDialogFolderPicker  允许用户选择一个文件夹。
　　　　msoFileDialogOpen  允许用户打开文件。用Excel打开。
　　　　msoFileDialogSaveAs  允许用户保存一个文件。
分别举例如下：

1、msoFileDialogFilePicker
1）选择单个文件

Sub SelectFile()
    '选择单一文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False   '单选择

　　　　　　.InitialFileName = 'ok'
　　　　　　.Title = 'Please select folder'

        .Filters.Clear   '清除文件过滤器
        .Filters.Add 'Excel Files', '*.xls;*.xlw'
        .Filters.Add 'All Files', '*.*'          '设置两个文件过滤器
        If .Show = -1 Then    'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
            MsgBox '您选择的文件是：' & .SelectedItems(1), vbOKOnly + vbInformation, '智能Excel'
        End If
    End With
End sub

2）选择多个文件

Sub SelectFile()
    '选择多个文件
    Dim l As Long
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True   '单选择
        .Filters.Clear     '清除文件过滤器
        .Filters.Add 'Excel Files', '*.xls;*.xlw'
        .Filters.Add 'All Files', '*.*'    '设置两个文件过滤器
        .Show
        'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
        For l = 1 To .SelectedItems.Count
            MsgBox '您选择的文件是：' & .SelectedItems(l), vbOKOnly + vbInformation, '智能Excel'
        Next
    End With
End Sub

2、msoFileDialogFolderPicker

Sub SelectFolder()
    '选择单一文件
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
        'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
            MsgBox '您选择的文件夹是：' & .SelectedItems(1), vbOKOnly + vbInformation, '智能Excel'
        End If
    End With
End Sub

3、msoFileDialogOpen
4、msoFileDialogSaveAs
使用方法与前两种相同
只是在.show可以用.Execute方法来实际打开或者保存文件

例如：

Sub SelectFile()
    '选择单一文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False   '单选择
        .Filters.Clear   '清除文件过滤器
        .Filters.Add 'Excel Files', '*.xls;*.xlw'
        .Filters.Add 'All Files', '*.*'          '设置两个文件过滤器
       .Execute
    End With
End Sub

5. GetOpenFilename

表达式.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)

参数

名称 必选/可选 数据类型 描述
FileFilter 可选 Variant 一个指定文件筛选条件的字符串。
FilterIndex 可选 Variant 指定默认文件筛选条件的索引号，取值范围为 1 到由 FileFilter 所指定的筛选条件数目。如果省略该参数，或者该参数的值大于可用筛选条件数，则使用第一个文件筛选条件。
Title 可选 Variant 指定对话框的标题。如果省略该参数，则标题为“打开”。
ButtonText 可选 Variant 仅限 Macintosh。
MultiSelect 可选 Variant 如果为 True，则允许选择多个文件名。如果为 False，则只允许选择一个文件名。默认值为 False。

Sub Test() '取得文件路径及名字
   PickFile2 = Application.GetOpenFilename('xls(*.xls;*.xlsx),*.xls;*.xlsx')
End Sub

 选择多个文件

Sub XXX()
    Dim arr()
    arr = Application.GetOpenFilename('所有支持文件 (*.xls;*.xlsx;*.csv),*.xls;*.xlsx;*.csv,Excel 文件 (*.xls),*.xls,Excel2007 文件 (*.xlsx),*.xlsx,CSV 文件 (*.csv),*.csv', , '选择文件', , True)
    For i = LBound(arr) To UBound(arr)
        Cells(i, 1).Value = arr(i)
    Next
End Sub

提取指定文件夹内的所有文件名() '含所有子文件夹内的文件

Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
    Dim Fso As Object, arrf$(), mf&
    Set Fso = CreateObject('Scripting.FileSystemObject')
    Call GetFiles(CreateObject('Shell.Application').BrowseForFolder(0, '请选择文件夹', 0, '').Self.Path, Fso, arrf, mf)
    [b1].Resize(mf) = Application.Transpose(arrf)
    Set Fso = Nothing
End Sub

Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
    Dim Folder As Object
    Dim SubFolder As Object
    Dim File As Object
    Set Folder = Fso.GetFolder(sPath)
    
    For Each File In Folder.Files
        mf = mf + 1
        ReDim Preserve arrf(1 To mf)
        arrf(mf) = File.Name
    Next
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(SubFolder.Path, Fso, arrf, mf)
    Next
    Set Folder = Nothing
    Set File = Nothing
End Sub

正常情况下想要遍历文件夹和子文件夹，可以采用递归的方式

Sub ListFilesTest()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> '\' Then myPath = myPath & '\'
[a:a] = ''
Call ListAllFso(myPath)
End Sub
Function ListAllFso(myPath$)
Set fld = CreateObject('Scripting.FileSystemObject').GetFolder(myPath)
For Each f In fld.Files
' [a65536].End(3).Offset(1) = f.Name
[a65536].End(3).Offset(1) = f.Path
Next
For Each fd In fld.SubFolders
' [a65536].End(3).Offset(1) = ' ' & fd.Name & ''
[a65536].End(3).Offset(1) = fd.Path
Call ListAllFso(fd.Path)
Next
End Function

但用过DOS命令的都知道，DOS有个命令，一句话就可以遍历文件夹和子文件夹，下面用vba来实现DOS的dir命令，实现上面的功能

Sub 遍历文件夹()
Dim WSH, wExec, sCmd As String, Result As String, ar
Set WSH = CreateObject('WScript.Shell')
' Set wExec = WSH.Exec('ping 127.0.0.1')
Set wExec = WSH.exec('cmd /c dir /b /s D:\lcx\*.xls*')
Result = wExec.StdOut.ReadAll
ar = Split(Result, vbCrLf)
For i = 0 To UBound(ar)
Cells(i + 1, 1) = ar(i)
Next
Set wExec = Nothing
Set WSH = Nothing
End Sub

在学习使用这个功能的时候看到一个网上的例子，写的很好，而且还让我意外的学习到一个filter的函数，这个函数的功能也是相当强大了

Sub ListFilesDos()
Set myfolder = CreateObject('Shell.Application').BrowseForFolder(0, 'GetFolder', 0)
If Not myfolder Is Nothing Then myPath$ = myfolder.Items.Item.Path Else MsgBox 'Folder not Selected': Exit Sub
'在这里输入需要指定的关键字，可以是文件名的一部分，或指定文件类型如 '.xlsx'
myFile$ = InputBox('Filename', 'Find File', '.xlsx')
tms = Timer
With CreateObject('Wscript.Shell')
'所有文档含子文件夹 chr(34)是双引号'',因为代码中要表达'',需要写成'''' vbCrLf 回车换行
ar = Split(.exec('cmd /c dir /a-d /b /s ' & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf)
s = 'from ' & UBound(ar) & ' Files by Search time: ' & Format(Timer - tms, ' 0.00000') & ' in: ' & myPath
' 这个filter竟然可以过滤数组，太厉害了，早知道有这个函数的话，以前写着玩的好些代码玩起来就省事多了
tms = Timer: ar = Filter(ar, myFile)
Application.StatusBar = Format(Timer - tms, '0.00000') & ' Find ' & UBound(ar) + IIf(myFile = '', 0, 1) & ' Files ' & s
End With
[a:a] = '': If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
End Sub

'上例简写如下

Sub ListFilesDos_lcx()
Set myfolder = CreateObject('Shell.Application').BrowseForFolder(0, 'GetFolder', 0)
If Not myfolder Is Nothing Then myPath$ = myfolder.Items.Item.Path Else MsgBox 'Folder not Selected': Exit Sub
With CreateObject('Wscript.Shell')
'所有文档含子文件夹 chr(34)是双引号'',因为代码中要表达'',需要写成'''' vbCrLf 回车换行
ar = Split(.exec('cmd /c dir /a-d /b /s ' & Chr(34) & myPath & '\*.xls*' & Chr(34)).StdOut.ReadAll, vbCrLf)
End With
[a:a] = '': If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
End Sub

shell命令也是很强大很好用了，电脑里的可执行文件，shell都可以执行，shell也是可以执行cmd的，只是无法获取到cmd控制台的数据

Sub 打开路径()
Shell 'cmd /c ipconfig > ''' & ThisWorkbook.Path & '\ip.txt'''
Shell 'explorer.exe ' & ThisWorkbook.Path, vbNormalFocus

End Sub