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 > 4Then .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 > 4Then
For i = 5To 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 = 58Then
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(1To999), k%
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fld = folder(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(1To10000) As String
Dim f, i, k, f2, f3, x
Dim arr1(1To100000, 1To1) 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, ".") = 0And f <> ""Then
k = k + 1
fn(k) = fn(i) & f & "\"
End If
f = Dir
Loop Until f = ""
i = i + 1
Loop
'*******接下来是提取各个⽂件夹的⽂件***
For x = 1To 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 = -1Then'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 = 1To .SelectedItems.Count
MsgBox"您选择的⽂件是：" & .SelectedItems(l), vbOKOnly + vbInformation, "智能Excel"
Next
End With
End Sub
2、msoFileDialogFolderPicker
Sub SelectFolder()
'选择单⼀⽂件
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1Then
'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(1To mf)
arrf(mf) = File.Name
resize函数vbaNext
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 = ("cmd /c dir /b /s D:\lcx\*.xls*")
Result = wExec.StdOut.ReadAll
ar = Split(Result, vbCrLf)
For i = 0To 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) > -1Then [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) > -1Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
End Sub
shell命令也是很强⼤很好⽤了，电脑⾥的可执⾏⽂件，shell都可以执⾏，shell也是可以执⾏cmd的，只是⽆法获取到cmd控制台的数据Sub打开路径()
Shell"cmd /c ipconfig > """ & ThisWorkbook.Path & "\ip.txt"""
" & ThisWorkbook.Path, vbNormalFocus
End Sub
发表评论