VBA 对 文件和文件夹的操作


我们在使用Excel VBA进行处理数据时,或多或少会涉及到如何操作文件和文件夹。本节将重点讲述如何新建、打开、删除复制、移动和重命名文件和文件夹操作等。

对于文件和文件夹操作,我们一般通过下面方法:
。VB命令
。EXCEL对象
。引用其他动态库对象
。API函数


在这里,我们尽可能通过不同的方法来展示如何操作文件和文件夹。注意,这里所涉及的文件一般以Excel为主。

对于如何运用文件之间的处理,如,文本文件、WORDACCESSPPTEXCEL之间的互访与查询,我们将在下节中讲解。

在本节开始之前,我们需要预备的知识点:
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

你可能感兴趣的:(String,shell,Excel,Microsoft,vb,VBA)