当前位置: 代码迷 >> VBA >> VBA 对 资料和文件夹的操作
  详细解决方案

VBA 对 资料和文件夹的操作

热度:6259   发布时间:2013-02-26 00:00:00.0
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 = "*" .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
  相关解决方案