fieldset{padding:10px;}
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 可是旅行的彼时那刻我的心情一直是好的吗?