点击刷新
在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
© 著作权归作者所有
举报
发表评论
0/200
