VBA 对 文件和文件夹的操作

VBA 对 文件和文件夹的操作
2010年06月24日
　　我们在使用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
　　Sub OpenText() Dim strFile As String Dim i As Long strFile = ThisWorkbook.Path With Application.FileSearch Application.DefaultWebOptions.LoadPictures = False .LookIn = strFile .Filename = "*.html" .Execute If .Execute() > 0 Then For i = 1 To .FoundFiles.Count Workbooks.OpenText .FoundFiles(i) Next End If Application.DefaultWebOptions.LoadPictures = True End With End Sub 
　　3）、Office对象：FileDialog
　　通过浏览方式打开文件
　　Sub OpenFile_FileDialog() Dim fd As FileDialog Dim FFs As FileDialogFilters Dim vaItem As Variant Dim myWb As Workbook Set fd = Application.FileDialog(msoFileDialogOpen) With fd Set FFs = .Filters With FFs .Clear .Add "Excel文件", "*.xls;*.xla" End With .AllowMultiSelect = True If .Show = -1 Then For Each vaItem In .SelectedItems Set myWb = Workbooks.Open(vaItem) Next vaItem End If End With End Sub
　　4）、API函数方式
　　打开所有类型的文件
　　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）、Excel对象：Save
　　Sub SaveWorkbook()
　　ThisWorkbook.Save End Sub
　　2）、Excel对象：SaveAs
　　Sub SaveAsWorkbook()
　　Dim strFileName As String
　　strFileName = ThisWorkbook.Path & "\test.xls"
　　On Error Resume Next
　　ThisWorkbook.SaveAs strFileName
　　End Sub
　　3）、Excel对象：SaveCopyAs
　　Sub SaveCopyAsWorkbook()
　　Dim strFileName As String
　　strFileName = ThisWorkbook.Path & "\test.xls"
　　On Error Resume Next
　　ThisWorkbook.SaveCopyAs strFileName
　　End Sub
　　2、判断文件夹是否存在
　　1）、VB命令：Dir()
　　Sub FileExist_Dir() Dim strFile As String strFile = ThisWorkbook.Path & "\test.xls" If Dir(strFile) = "" Then MsgBox strFile & " does not Exists" Else MsgBox strFile & " Exist" End If End Sub 
　　2）、FileSystemObject对象：FileExists方法
　　Sub FileExist_Fso() Dim fso As FileSystemObject Dim strFile As String strFile = ThisWorkbook.Path & "\test.xls" Set fso = New FileSystemObject If fso.FileExists(strFile) Then MsgBox strFile & " Exist" Else MsgBox strFile & " does not Exists" End If End Sub 1、建立文件的桌面快捷方式
　　WScript 对象：CreateShortCut方法
　　Sub DesktopShortCut() Dim WSHShell As Object Dim MyShortcut As Object Dim DesktopPath As String Set WSHShell = CreateObject("WScript.Shell") DesktopPath = WSHShell.SpecialFolders("Desktop") Set MyShortcut = WSHShell.CreateShortcut(DesktopPath & "\" & _ ThisWorkbook.Name & ".lnk") With MyShortcut .TargetPath = ThisWorkbook.FullName .Save End With Set WSHShell = Nothing MsgBox "已经在桌面生成快捷方式." End Sub 
　　2、移动文件
　　1）、FileSystemObject对象：MoveFilet
　　Sub MoveFile_fso() Dim fso As New FileSystemObject Dim strSourceFile As String Dim strDestination As String strSourceFile = ThisWorkbook.Path & "\Temp.xls" strDestination = ThisWorkbook.Path & "\MoveFile\Temp.xls" If Not fso.FileExists(strSourceFile) Then MsgBox "File does not Exists.", vbCritical Else fso.MoveFile strSourceFile, strDestination MsgBox "File Move to " & strDestination End If Set fso = Nothing End Sub 
　　2）、Office对象：Name
　　Sub MoveFile() Dim fso As New FileSystemObject Dim strSourceFile As String Dim strDestination As String On Error GoTo ErrHandle strSourceFile = ThisWorkbook.Path & "\Temp.xls" strDestination = ThisWorkbook.Path & "\MoveFile\Temp.xls" dir(strSourceFile)=""? Name strSourceFile As strDestination Exit Sub ErrHandle: MsgBox Err.Description, vbCritical End Sub 1、复制文件
　　1）、Office对象：FileCopy
　　Sub CopyFile() Dim strSfile As String Dim strDfile As String strSfile = ThisWorkbook.Path & "\Temp.xls" strDfile = ThisWorkbook.Path & "\Temp\Temp.xls" FileCopy strSfile, strDfile End Sub 
　　2）、FileSystemObject对象：CopyFile
　　Sub CopyFile_fso() Dim strSfile As String Dim strDfile As String Dim fso As New FileSystemObject strSfile = ThisWorkbook.Path & "\Temp.xls" strDfile = ThisWorkbook.Path & "\Temp\Temp.xls" fso.CopyFile strSfile, strDfile Set fso = Nothing End Sub 
　　2、关闭文件
　　Excel对象：Close方法
　　Sub CloseWorkbook()
　　ThisWorkbook.Close False End Sub 1、文件重命名
　　Office对象：Name 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 
　　删除文件
　　1）、VB语句：Kill
　　Sub DeleteFile() Dim strFile As String strFile = ThisWorkbook.Path & "\Temp.xls" Kill strFile End Sub Sub DeleteFile2() Dim strFile As String strFile = ThisWorkbook.Path & "\Temp.xls" If Dir(strFile) = "" Then MsgBox strFile & " does not Exists", vbCritical Else Kill strFile End If End Sub 
　　2）、FileSystemObject对象：DeleteFile方法
　　Sub DeleteFile_Fso() Dim fso As FileSystemObject Dim strFile As String strFile = ThisWorkbook.Path & "\test.xls" Set fso = New FileSystemObject If fso.FileExists(strFile) Then fso.DeleteFile strFile Else MsgBox strFile & " does not Exists" End If Set fso = Nothing End Sub
　　10、文件自杀
　　VB语句：Kill 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