第9章--文件操作代码【超实用VBA】

94第9章文件操作范例134导入文本文件134-1使用查询表导入SubAddQuery()WithSheet2.UsedRange.ClearContentsWith.QueryTables.Add(Connection:=TEXT;&ThisWorkbook.Path&\工资表.txt,Destination:=.Range(A1)).TextFileCommaDelimiter=True.RefreshEndWith.SelectEndWithEndSub134-2使用Open语句导入SubOpenText()DimMyTextAsStringDimMyArr()AsStringDimcAsIntegerDimrAsIntegerr=1WithSheet2.UsedRange.ClearContentsOpenThisWorkbook.Path&\工资表.txtForInputAs#1DoWhileNotEOF(1)LineInput#1,MyTextMyArr=Split(MyText,,)Forc=0ToUBound(MyArr).Cells(r,c+1)=MyArr(c)Nextr=r+1Loop95Close#1.SelectEndWithEndSub134-3使用OpenText方法SubOpenText()Sheet2.UsedRange.ClearContentsWorkbooks.OpenTextFilename:=ThisWorkbook.Path&\&工资表.txt,StartRow:=1,DataType:=xlDelimited,Comma:=TrueWithActiveWorkbookWith.Sheets(工资表).Range(A1).CurrentRegionThisWorkbook.Sheets(Sheet2).Range(A1).Resize(.Rows.Count,.Columns.Count).Value=.ValueEndWith.CloseFalseEndWithSheet2.SelectEndSub范例135将数据写入文本文件135-1使用Print#语句SubPrintText()DimFileAsStringDimArr()AsVariantDimStrAsStringDimrAsIntegerDimcAsIntegerDimiAsIntegerDimjAsIntegerOnErrorResumeNextFile=ThisWorkbook.Path&\&工资表.txtKillFileWithSheet2r=.UsedRange.Rows.Countc=.UsedRange.Columns.CountReDimArr(1Tor,1Toc)Fori=1TorForj=1Toc96Arr(i,j)=.Cells(i,j).ValueNextNextEndWithOpenFileForOutputAs#1Fori=1ToUBound(Arr,1)Str=Forj=1ToUBound(Arr,2)Str=Str&CStr(Arr(i,j))&,NextStr=Left(Str,(Len(Str)-1))Print#1,StrNextClose#1MsgBox文件保存成功!EndSub135-2使用SaveAs方法SubSaveText()DimFileAsStringFile=ThisWorkbook.Path&\工资表.txtOnErrorResumeNextKillFileSheet2.CopyActiveWorkbook.SaveAsFileName:=File,FileFormat:=xlCSVActiveWorkbook.CloseSaveChanges:=FalseMsgBox文件保存成功!EndSub范例136获得文件修改的日期和时间SubMyDateTime()DimStrAsStringStr=ThisWorkbook.Path&\&ThisWorkbook.NameMsgBoxStr&的最后修改时间是：&Chr(13)&FileDateTime(Str)EndSub范例137查找文件和文件夹SubMyName()DimMyNameAsString97DimrAsIntegerr=1Columns(A).ClearContentsMyName=Dir(ThisWorkbook.Path&\,vbDirectory)DoWhileMyNameIfMyName.AndMyName..ThenCells(r,1)=MyNamer=r+1EndIfMyName=DirLoopEndSub范例138获得当前文件夹SubCurFolder()MsgBoxCurDir(D)EndSub范例139创建和删除文件夹SubCreateFolder()OnErrorResumeNextMkDirThisWorkbook.Path&\TempEndSubSubDeleteFolder()OnErrorResumeNextRmDirThisWorkbook.Path&\TempEndSub范例140重命名文件或文件夹SubRenameFiles()DimMyPathAsStringOnErrorResumeNextMyPath=ThisWorkbook.PathNameMyPath&\123AsMyPath&\ABCNameMyPath&\123.xlsxAsMyPath&\ABC\ABC.xlsxEndSub98范例141复制指定的文件SubCopyingFiles()DimSourceFileAsStringDimDestinationFileAsStringSourceFile=ThisWorkbook.Path&\123.xlsxDestinationFile=ThisWorkbook.Path&\ABC\abc.xlsxFileCopySourceFile,DestinationFileEndSub范例142删除指定的文件SubDeleteFiles()DimmyFileAsStringmyFile=ThisWorkbook.Path&\123.xlsxIfDir(myFile)ThenKillmyFileEndSub范例143使用WSH处理文件143-1获取文件信息SubFileInformation()DimMyFileAsObjectDimStrAsStringDimStrMsgAsStringStr=ThisWorkbook.Path&\123.xlsxSetMyFile=CreateObject(Scripting.FileSystemObject)WithMyFile.Getfile(Str)StrMsg=StrMsg&文件名称：&.Name&Chr(13)_&文件创建日期：&.DateCreated&Chr(13)_&文件修改日期：&.DateLastModified&Chr(13)_&文件访问日期：&.DateLastAccessed&Chr(13)_&文件保存路径：&.ParentFolderEndWithMsgBoxStrMsgSetMyFile=NothingEndSub99143-2取得文件基本名SubFileBaseName()DimMyFileAsObjectDimFileNameAsVariantSetMyFile=CreateObject(Scripting.FileSystemObject)FileName=Application.GetOpenFilenameIfFileNameFalseThenMsgBoxMyFile.GetBaseName(FileName)EndIfSetMyFile=NothingEndSub143-3查找文件SubFindFiles()DimMyFileAsObjectDimStrAsStringStr=ThisWorkbook.Path&\123.xlsxSetMyFile=CreateObject(Scripting.FileSystemObject)IfNotMyFile.FileExists(Str)ThenMsgBox文件不存在!ElseMsgBox文件已找到!EndIfSetMyFile=NothingEndSub143-4搜索文件SubSearchFiles()DimMyFileAsObjectDimMyFilesAsObjectDimMyStrAsStringSetMyFile=CreateObject(Scripting.FileSystemObject)_.Getfolder(ThisWorkbook.Path)ForEachMyFilesInMyFile.FilesIfInStr(MyFiles.Name,.xlsx)0ThenMyStr=MyStr&MyFiles.Name&Chr(13)EndIfNextMsgBoxMyStrSetMyFile=NothingSetMyFiles=Nothing100EndSub143-5移动文件SubMovingFiles()DimMyFileAsObjectOnErrorResumeNextSetMyFile=CreateObject(Scripting.FileSystemObject)MyFile.MoveFileThisWorkbook.Path&\123.xlsx,ThisWorkbook.Path&\abc\SetMyFile=NothingEndSub143-6复制文件SubCopyingFiles()DimMyFileAsObjectOnErrorResumeNextSetMyFile=CreateObject(Scripting.FileSystemObject)MyFile.CopyFileThisWorkbook.Path&\123.xlsx,ThisWorkbook.Path&\abc\SetMyFile=NothingEndSub143-7删除文件SubDeleteFiles()DimMyFileAsObjectOnErrorResumeNextSetMyFile=CreateObject(Scripting.FileSystemObject)MyFile.DeleteFileThisWorkbook.Path&\123.xlsxSetMyFile=NothingEndSub143-8创建文件夹SubCreateFolder()DimMyFileAsObjectOnErrorResumeNextSetMyFile=CreateObject(Scripting.FileSystemObject)MyFile.CreateFolder(ThisWorkbook.Path&\abc)SetMyFile=NothingEndSub101143-9复制文件夹SubCopyFolder()DimMyFileAsObjectSetMyFile=CreateObject(Scripting.FileSystemObject)MyFile.CopyFolderThisWorkbook.Path&\ABC,ThisWorkbook.Path&\123SetMyFile=NothingEndSub143-10移动文件夹SubMoveFolders()DimMyFileAsObjectOnErrorResumeNextSetMyFile=CreateObject(Scripting.FileSystemObject)MyFile.MoveFolderThisWorkbook.Path&\123,ThisWorkbook.Path&\abc\SetMyFile=NothingEndSub143-11删除文件夹SubDeleteFolders()DimMyFileAsObjectOnErrorResumeNextSetM