我们在使用Excel VBA进行处理数据时,或多或少会涉及到如何操作文件和文件夹。本节将重点讲述如何新建、打开、删除、复制、移动和重命名文件和文件夹操作等。
对于文件和文件夹操作,我们一般通过下面方法:
。VB命令
。EXCEL对象
。引用其他动态库对象
。API函数
在这里,我们尽可能通过不同的方法来展示如何操作文件和文件夹。注意,这里所涉及的文件一般以Excel为主。
对于如何运用文件之间的处理,如,文本文件、WORD、ACCESS和PPT与EXCEL之间的互访与查询,我们将在下节中讲解。
在本节开始之前,我们需要预备的知识点:
1、如何引用动态工程库。
打开VBE-工具-引用
选择Microsoft Scripting Runtime动态库
下面我们将会频繁用到Scripting.FileSystemObject对象来操作文件和文件夹。
另,此scrrun.dll动态库还包含了Scripting.Dictionary字典对象。
2、前期绑定和后期绑定
我们知道,VB是面向对象化编程,MS提供很多的DLL动态链接库,通过这些对象,我们可以轻松地完成任务。我们可以通过前期绑定或后期绑定来引用DLL库。
1)前期绑定。如同我们在上面用手动引用动态工程库方式,在编译代码前,我们就完成了的绑定。绑定之后,写入下面代码,创建和引用对象:
Sub BandObject()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
DIM FSO NEW Scripting.FileSystemObject
End Sub
2)后期绑定。使用CreateObject函数,绑定某一个对象。此时,我们只有在程序运行时,绑定才有效,如,
Sub CrtObject()
Dim ObjFso As Object
Set ObjFso = CreateObject("Scripting.FileSystemObject")
End Sub
3、小结:
1)、前期和后期绑定区别在于定义方式和创建方式不同。
2)、前期绑定的优势在于,可以使用自动列出成员方式,查看对象的方法和属性;而后期绑定无法使用。
3)、小心后期绑定的写法。不是所有的后期绑定都是和前期绑定的对象写法一致。如,对象库:Microsoft Shell Controls And Automation
前期绑定:
Dim oShell As Shell32.Shell
Set oShell = New Shell32.Shell
后期绑定:
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
一、文件操作
1、新建Excel文件
Excel对象:Add方法:
Sub AddWorkBook() Dim wb As Workbook Set wb = Workbooks.Add End Sub Sub AddFile() Dim wb As Workbook Set wb = Workbooks.Add wb.SaveAs ThisWorkbook.Path & "/Temp.xls" wb.Close Set wb = Nothing End Sub
2、打开文件
1)、EXCEL对象:Open方法
直接打开一个工作簿。
expression.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad, OpenConflictDocument)
Sub OpenWorkbook() Dim wb As Workbook Dim strWb As String strWb = ThisWorkbook.Path & "/Temp.xls" Set wb = Workbooks.Open(strWb) End Sub Sub OpenWorkbook2() Dim wb As Workbook Dim strWb As String strWb = ThisWorkbook.Path & "/Temp.xls" Set wb = Workbooks.Open(strWb, UpdateLinks:=False) End Sub
2)、Excel对象:OpenText Const SW_SHOW = 5 Private Declare Function ShellExecute Lib "shell32.dll" Alias _ "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Sub OpenFiles() Dim varFName As Variant Dim fn As Variant 'Excel档由Excel开,其它文档由ShellExecute函数开 varFName = Application.GetOpenFilename(, , "开启文档", MultiSelect:=True) If IsArray(varFName) Then For Each fn In varFName If LCase(Right(fn, 3)) <> "xls" Then ShellExecute 0, "open", fn, "", "", SW_SHOW Else Workbooks.Open (fn) End If Next End If End Sub
1、保存文件
1、建立文件的桌面快捷方式 1、复制文件
1、文件重命名 Public oldNames() As String, newNames() As String Sub ReNameFiles() Dim i As Integer, iCount As Integer Dim Oldname As String, Newname As String Dim strExName As String, strPath As String strExName = ".jpg" strPath = ThisWorkbook.Path & "/Rename Pic/" With Application.FileSearch .NewSearch .LookIn = strPath .SearchSubFolders = False .Filename = "*" & strExName .MatchTextExactly = True .FileType = msoFileTypeAllFiles On Error GoTo ErrH If .Execute() > 0 Then iCount = .FoundFiles.Count MsgBox "There were " & iCount & " file(s) found.", 0 + 64, "系统" ReDim oldNames(iCount) ReDim newNames(iCount) For i = 1 To iCount Newname = i & strExName newNames(i) = CStr(strPath & "/" & Newname) oldNames(i) = CStr(.FoundFiles(i)) Name CStr(oldNames(i)) As newNames(i) Next i Else MsgBox "There were no files found." End If Application.OnUndo "撤销重命名", "UnChangePicName" End With Exit Sub ErrH: MsgBox Err.Description, vbCritical End Sub Sub UnChangePicName() '撤销重命名图片 Dim i As Integer For i = 1 To UBound(newNames) Name newNames(i) As oldNames(i) Next i Application.OnRepeat "重做重命名", "my_Repeat" End Sub Sub my_Repeat() '恢复重命名图片 Dim i As Integer For i = 1 To UBound(newNames) Name oldNames(i) As newNames(i) Next i Application.OnUndo "撤销重命名", "UnChangePicName" End Sub
删除文件 Sub KillMe() Application.DisplayAlerts = False ActiveWorkbook.ChangeFileAccess xlReadOnly Kill ActiveWorkbook.FullName ThisWorkbook.Close False End Sub
|
二.文件夹操作
1、新建文件夹
Sub MkDirFolder() Dim strfolder As String strfolder = ThisWorkbook.Path & "/Temp" On Error GoTo ErrHandle MkDir strfolder MsgBox "Create New Folder: " & strfolder, vbInformation On Error GoTo 0 Exit Sub ErrHandle: MsgBox "Folder already Exists.", vbInformation End Sub Sub MakeFolder_fso() Dim fso As New FileSystemObject Dim strfolder As String strfolder = ThisWorkbook.Path & "/Temp" If Not fso.FolderExists(strfolder) Then fso.CreateFolder strfolder MsgBox "Create a Temp folder.", vbInformation Else MsgBox "Folder already Exists.", vbInformation End If Set fso = Nothing End Sub
2、打开文件夹
1)、Shell
Sub ShellFolder() Shell "explorer.exe E:/inbox/", 1 End Sub
2)、引用Microsoft Shell Controls And Automation动态库
Sub OpenFolder() Dim strFolder As String Dim oShell As Shell32.Shell Set oShell = New Shell32.Shell strFolder = "E:/inbox/" oShell.Explore strFolder End Sub
1)后期绑定方式,选择文件夹
Sub SelectFolder() Dim Shapp As Object Dim Path1 As Object Set Shapp = CreateObject("Shell.Application") Set Path1 = Shapp.BrowseForFolder(0, "请选择文件夹", 0, 0) If Path1 Is Nothing Then Exit Sub MsgBox Path1.Self.Path End Sub
2、复制文件夹
FileSystemObject对象:CopyFolder
Sub CopyFile_fso() Dim fso As New FileSystemObject Dim strSfolder As String Dim strDfolder As String strSfolder = ThisWorkbook.Path & "/Temp" strDfolder = ThisWorkbook.Path & "/MoveFile/" fso.CopyFolder strSfolder, strDfolder Set fso = Nothing End Sub
1、移动文件夹
FileSystemObject对象:MoveFolder
Sub MoveFolder_fso() Dim fso As New FileSystemObject Dim strSfolder As String Dim strDfolder As String strSfolder = ThisWorkbook.Path & "/Temp" strDfolder = ThisWorkbook.Path & "/MoveFile/" If Not fso.FolderExists(strSfolder) Then MsgBox " Folder does not Exists.", vbCritical Else fso.MoveFolder strSfolder, strDfolder MsgBox "Folder Move to " & strDfolder End If Set fso = Nothing End Sub
2、删除文件夹
VB语句:RmDir
Sub DeleteFolder() Dim strFolder As String strFolder = ThisWorkbook.Path & "/Temp" On Error GoTo ErrHandle RmDir strFolder MsgBox "Delete Folder: " & strFolder, vbInformation On Error GoTo 0 Exit Sub ErrHandle: MsgBox "Folder does not Exists.", vbCritical End Sub
Shell语句
Sub DeleteFolder2() KillFolder ThisWorkbook.Path & "/Temp" End Sub Sub KillFolder(MyFolderPath As String) Shell "cmd.exe /c rmdir /s/q " & Chr(34) & MyFolderPath & Chr(34) End Sub
FileSystemObject对象:DeleteFolder
Sub DeleteFolder_fso() Dim strFolder As String Dim fso As New FileSystemObject strFolder = ThisWorkbook.Path & "/Temp" If fso.FolderExists(strFolder) Then fso.DeleteFolder strFolder Else MsgBox "Folder does not Exists.", vbCritical End If Set fso = Nothing End Sub
1、获取父文件夹名
FileSystemObject对象:ParentFolder
Sub ParentFolderName_fso() Dim fso As New FileSystemObject Dim strPath As String strPath = ThisWorkbook.Path & "/Temp" MsgBox "Path: " & strPath & vbCrLf & vbCrLf & _ "Paren Path: " & fso.GetFolder(strPath).ParentFolder.Name End Sub
VBA :Split函数
Sub ParentFolderName() Dim arr As Variant Dim strPath As String strPath = ThisWorkbook.Path & "/Temp" arr = Split(strPath, "/") MsgBox "Path: " & strPath & vbCrLf & vbCrLf & _ "Paren Path: " & arr(UBound(arr) - 1) End Sub
2、文件夹重命名
FileSystemObject对象:Folder.name
Dim OldFolder As String, NewFolder As String Sub ReNameFolder_fso() Dim fso As New FileSystemObject Dim oFolder As Folder Dim strOldFolder As String Dim strNewFolder As String strOldFolder = ThisWorkbook.Path & "/Temp" strNewFolder = "New Temp" If Not fso.FolderExists(strOldFolder) Then MsgBox "Folder does not Exist.", vbCritical Else Set oFolder = fso.GetFolder(strOldFolder) oFolder.Name = strNewFolder End If End Sub
VB语句:Name
Sub ReNameFolder() OldFolder = ThisWorkbook.Path & "/Temp" NewFolder = ThisWorkbook.Path & "/New Temp" Name OldFolder As NewFolder End Sub Sub UnChangeReNameFolder() Name NewFolder As OldFolder End Sub