VBA文件及文件夹操作.pdf

《VBA文件及文件夹操作.pdf》由会员分享，可在线阅读，更多相关《VBA文件及文件夹操作.pdf（32页珍藏版）》请在淘文阁 - 分享文档赚钱的网站上搜索。

1、 VBA 文件及文件夹操作 1.VBA 操作文件及文件夹 on error resume next 下测试 A，在 D：下新建文件夹,命名为 folder 方法 1：MkDir”D：folder 方法 2：Set abc=CreateObject（Scripting。FileSystemObject）abc。CreateFolder（D：folder”)B，新建 2 个文件命名为 a.xls 和 b。xls Workbooks。Add ActiveWorkbook。SaveAs Filename：=D:foldera.xls ActiveWorkbook.SaveAs Filename：=”D

2、:folderb.xls C，创建新文件夹 folder1 并把 a。xls 复制到新文件夹重新命名为 c。xls MkDir D：folder1 FileCopy”D：foldera.xls，D：folder1c.xls”D，复制 folder 中所有文件到 folder1 Set qqq=CreateObject（”Scripting.FileSystemObject”)qqq。CopyFolder D：folder”，D：folder1 D,重命名 a.xls 为 d.xls name d:folder1a。xls”as”d：folder1d。xls”E，判断文件及文件夹是否存在 Set

3、 yyy=CreateObject(”Scripting。FileSystemObject”）If yyy。FolderExists（”D:folder1）=True Then。.。If yyy。FileExists（D：folder1d.xls）=True Then。.F,打开 folder1 中所有文件 Set rrr=CreateObject(”Scripting.FileSystemObject”)Set r=rrr。GetFolder（d：folder1”)For Each i In r.Files Workbooks.Open Filename：=（”d：folder1+i.Nam

4、e+）Next G,删除文件 c。xls kill”d：folder1c.xls H,删除文件夹 folder Set aaa=CreateObject(”Scripting.FileSystemObject”)aaa.DeleteFolder”d：folder”2.8excel vba 一次性获取文件夹下的所有文件名的方法 小生今天上网下载了一个财务常用报表的文件包，里面有几百个 excel 工作表,要是手工一个一个的获得文件名的话，那我可是要忙十天半月哦。于是想到昨论 坛就是 vba 论坛，昨不充分利用 excel 自身的高级应用呀,呵呵,实现的代码如下，把工作量几天的任务可是一下子就完成

5、了，这就是 excel vba 给你工作提高效率的结果！excle vba 自动获取同一文件夹下所有工作表的名称红色代码：按 Alt+F11，打开 VBA 编辑器,插入一个模块，把下面的代码贴进去，按F5 执行 Sub t(）Dim s As FileSearch 定义一个文件搜索对象 Set s=Application.FileSearch s.LookIn=c：”注意路径，换成你实际的路径 s。Filename=.*搜索所有文件 s.Execute 执行搜索 Cells。Delete 表格清空 For i=1 To s。FoundFiles。Count Cells（i，1）=s.Found

6、Files（i)每一行第一列填写一个文件名 Next End Sub 现在获得的可是带路径的工作表名，去掉前的路径可用以下方法;=RIGHT（A1,LEN（A1）FIND（”,SUBSTITUTE(A1，”,”#，LEN（A1)LEN(SUBSTITUTE(A1,”,)最后用常规的方法往下拖,就完成了笔者所需的工作表名。outlook 下 VBA 编程：把公用文件夹里的邮件附件拷贝出来保存在硬盘上 2009-0617 09：35 Sub SaveAttachments(）Dim oApp As Outlook.Application Dim oNameSpace As NameSpace Di

7、m oFolder As MAPIFolder Dim oMailItem As Object Dim sMessage As String BeforeDate=#10/1/2007#choose the end date of wanted MyDir=E：liuxc-workoil lossbackup from public folder choose the folder location for save Sender=”Hz121 Supervisor”caution,case sensitive SendFile=”HZ121-1_Daily。xls MyY=0 Set oAp

8、p=New Outlook.Application Set oNameSpace=oApp.GetNamespace（MAPI）Set oFolder=oNameSpace。PickFolder For Each oMailItem In oFolder.Items With oMailItem MyT3=Left（CStr(oMailItem.CreationTime),10）If CDate（oMailItem。CreationTime）=BeforeDate Then If oMailItem。SenderName=Sender Then If oMailItem.Attachments

9、。Count 0 Then protect error For i=1 To oMailItem.Attachments.Count If oMailItem。Attachments.Item（i）.FileName=SendFile Then MyT1=InStr（1,oMailItem。Attachments。Item(i）.FileName,”。”,1）MyT2=Left(oMailItem。Attachments。Item(i）.FileName,19）+-”+MyT3+。xls oMailItem.Attachments.Item（i）.SaveAsFile MyDir MyT2 M

10、sgBox oMailItem.Attachments。Item(i)。DisplayName ”was saved as”oMailItem.Attachments。Item（i)。FileName End If Next i End If End If Else MyY=MyY+1 If MyY 10 Then GoTo LoopEnd End If End With Next oMailItem LoopEnd:Set oMailItem=Nothing Set oFolder=Nothing Set oNameSpace=Nothing Set oApp=Nothing 3.Excel

11、 VBA 把选定文件夹中的工作簿导入到新建 ACCESS 数据库中 2010-04-24 22：33 方法一 Sub Create_AccessProject(）Dim AccessData As Object Set AccessData=CreateObject（Access.Application)Dim Stpath As String Stpath=ThisWorkbook。Path&”DSEM-Stock-Allocation.mdb”设定路径 If Dir（Stpath，vbDirectory)=”DSEM-StockAllocation。mdb Then Kill(Stpath

12、)End If AccessData。NewCurrentDatabase Stpath Set AccessData=Nothing 创建表格 Set cnnaccess=CreateObject(”Adodb。Connection）Set rstAnswers=CreateObject（Adodb.Recordset”)cnnaccess。Provider=”Microsoft。Jet。OLEDB。4。0 Application。Wait Now（）+TimeValue（00：00：02）系统暂停 2秒,以等待 data.mdb 建立成功 cnnaccess。Open Data Sourc

13、e=&Stpath&”；Jet OLEDB：Database Password=&”strSQL=”Create Table myData（last_date char(8)）”rstAnswers.Open strSQL,cnnaccess Set rstAnswers=Nothing Set cnnaccess=Nothing MyMainFile=ThisWorkbook。Name Dim CurFile As String Application。DisplayAlerts=False myFile=Application。GetOpenFilename(”(*.xls)，*。xls）

14、，Please Select Files)If myFile=False Then Exit Sub DirLoc=CurDir（myFile)”CurFile=Dir（DirLoc&”*.xls）Do While CurFile vbNullString Set objAccess=CreateObject（Access。Application)LinkFile=DirLoc CurFile TableName=Left（CurFile，Len（CurFile)-4)If CurFile=HONHAI-VMIData1。xls”Then With objAccess.OpenCurrentD

15、atabase（ThisWorkbook。Path ”DSEM-Stock-Allocation.mdb”）.DoCmd。TransferSpreadsheet acLink，8,TableName，LinkFile,True，”Aging Report$”End With objAccess。CloseCurrentDatabase Set objAccess=Nothing CurFile=Dir Else With objAccess。OpenCurrentDatabase（ThisWorkbook.Path&DSEMStockAllocation.mdb）.DoCmd.Transfer

16、Spreadsheet acImport，8,TableName,LinkFile,True,”End With objAccess.CloseCurrentDatabase Set objAccess=Nothing CurFile=Dir End If Loop End Sub 方法二 Sub Folder2Access(）Dim db As DAO。Database Dim ws As DAO.Workspace Set ws=DBEngine。Workspaces(0)Set db=ws.OpenDatabase(”C：CustomersDataBaseDSEMPO-StockStat

17、us.mdb”，False，False，”）db。Execute（”delete*from DSEM-MovingPlan”）db.Close Set db=Nothing Dim myFile As String Dim s As FileSearch 定义一个文件搜索对象 Set s=Application。FileSearch s。LookIn=”C：CustomersDataBaseTest 注意路径,换成你实际的路径 s。Filename=*.*搜索所有文件 s.Execute 执行搜索 For i=1 To s.FoundFiles。Count FullName1=Right(s.

18、FoundFiles（i），Len(s.FoundFiles(i）Len(”C：CustomersDataBaseTest）Filename=Left(FullName1,Len（FullName1）4）Set objAccess=CreateObject（Access。Application”)myFile=C:CustomersDataBaseTest&Filename&。xls”With objAccess.OpenCurrentDatabase（C：CustomersDataBaseDSEM-POStock-Status.mdb）.DoCmd。TransferSpreadsheet a

19、cImport，8,”DSEM-MovingPlan,myFile，True,”End With objAccess.CloseCurrentDatabase Set objAccess=Nothing Next End Sub 4.vba 操作文件及文件夹示例 2009-0820 00：07 vba 操作文件及文件夹示例 利用 excel 中的 vba 可以对电脑中的文件及文件夹做一些常用的操作.包括复制、重命名、删除等，其中一些简单的示例总结如下.希望对一些经常需要批量处理文件的朋友有所帮助,也希望感兴趣的朋友多多指教！以下代码建议在 on error resume next 下测试 1，

20、在 D：下新建文件夹，命名为 folder 方法 1：MkDir”D：folder 方法 2：Set abc=CreateObject(”Scripting.FileSystemObject”）abc.CreateFolder（”D:folder”）2,新建 2 个文件命名为 a。xls 和 b。xls Workbooks。Add ActiveWorkbook。SaveAs Filename：=D：foldera。xls ActiveWorkbook.SaveAs Filename：=D：folderb.xls 3,创建新文件夹 folder1 并把 a。xls 复制到新文件夹重新命名为 c.

21、xls MkDir D：folder1 FileCopy”D：foldera.xls”，D：folder1c。xls”4，复制 folder 中所有文件到 folder1 Set qqq=CreateObject(Scripting。FileSystemObject”)qqq.CopyFolder D:folder”,D：folder1 5,重命名 a.xls 为 d.xls name d：folder1a.xls”as”d：folder1d。xls 6,判断文件及文件夹是否存在 Set yyy=CreateObject(”Scripting。FileSystemObject”）If yyy。

22、FolderExists(D：folder1）=True Then。.If yyy.FileExists（D：folder1d。xls）=True Then。.7，打开 folder1 中所有文件 Set rrr=CreateObject（Scripting。FileSystemObject”）Set r=rrr.GetFolder(”d：folder1”)For Each i In r.Files Workbooks.Open Filename：=(d：folder1”+i。Name+)Next 8，删除文件 c.xls kill d：folder1c.xls”9，删除文件夹 folder

23、Set aaa=CreateObject(Scripting。FileSystemObject)aaa。DeleteFolder”d：folder”VBA Dir 函数 遍历文件夹下的所有文件 2010-0526 17：30 5.VBA Dir 函数 第 1.12 例 Dir 函数 一、题目：要求编写一段代码,运用 Dir 函数返回一个文件夹的文件列表.二、代码：Sub 示例_1_12()Dim wjm wjm=Dir(C：WINDOWSWIN。ini”）MsgBox wjm wjm=Dir（”C：WINDOWS。ini”）wjm=Dir End Sub 三、代码详解 1、Sub 示例_1_1

24、2（）：宏程序的开始语句。宏名为示例_1_12.2、Dim wjm：变量 wjm 声明为可变型数据类型。3、wjm=Dir（”C：WINDOWSWIN。ini”）:如果该文件存在则返回“WIN.INI”（在 C：Windows 文件夹中)，把返回的文件名赋给变量 wjm。如果该文件不存在则 wjm=”。4、wjm=Dir（C：WINDOWS.ini）：返回带指定扩展名的文件名.如果超过一个*.ini 文件存在，函数将返回按条件第一个找到的文件名。5、wjm=Dir :若第二次调用 Dir 函数，但不带任何参数,则函数将返回同一目录下的下一个*.ini 文件。Dir 函数 返回一个字符串 Str

25、ing,用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配.Dir（pathname，attributes）Dir 函数的语法具有以下几个部分：pathname 可选参数。用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串(）。attributes 可选参数。常数或数值表达式,其总和用来指定文件属 性。如果省略，则会返回匹配 pathname 但不包含属性的文件。EXCEL 的 VBA 用于同时显示目录文件夹和文件列表 20100522 18：41”VBA 工具中要引用 microsoft s

26、cipting runtime Dim pt As Range Sub 查找文件夹下子文件夹及其大小()Dim theDir As String Set pt=ActiveSheet。Range(a1”)pt。Worksheet。Columns(1)。ClearContents 清除第一列 theDir=Application。InputBox （”输入指定文件夹的路径：”,查看子文件夹及其大小)pt=theDir 列出选取的目录名 listPath theDir 用于列出子目录和文件 pt.Worksheet。Columns(a:b”）.AutoFit End Sub Sub listPat

27、h（strDir As String）Dim thePath As String Dim strSdir As String Dim theDirs As Scripting.Folders Dim theDir As Scripting。Folder Dim row As Integer Dim s As String Dim myFso As Scripting。FileSystemObject Set myFso=New Scripting.FileSystemObject If Right(strDir，1）”Then strDir=strDir&”thePath=thePath&st

28、rDir row=pt.row 此段为获取此目录下的文件名 s=Dir(thePath，7)获取第一个文件 Do While s row=row+1 Cells（row，1）=s 文件的名称 Cells（row,1）。Font。Color=RGB(256,12,213)Cells（row，1)。Font。Bold=Ture s=Dir 下一个文件 Loop Set pt=Cells（row，1)Set pt=pt.Offset（1，0)Set theDirs=myFso.getfolder(strDir）。subfolders For Each theDir In theDirs pt=the

29、Dir。Path pt.Next=theDir.Size listPath theDir.Path Next Set myFso=Nothing End Sub Private Sub CommandButton1_Click（）查找文件夹下子文件夹及其大小 End Sub 6.用 VBA 获取文件夹中的文件列表 如果我们要在 Excel 中获取某个文件夹中所有的文件列表,可以通过下面的 VBA 代码来进行.代码运行后,首先弹出一个浏览文件夹对话框，然后新建一个工作簿，并在工作表的 A 至 F 列分别列出选定文件夹中的所有文件的文件名、文件大小、创建时间、修改时间、访问时间及完整路径。方法如下

30、：1。按 Alt+F11，打开 VBA 编辑器,单击菜单“插入模块，将下面的代码粘贴到右侧的代码窗口中：Option Explicit Sub GetFileList(）Dim strFolder As String Dim varFileList As Variant Dim FSO As Object,myFile As Object Dim myResults As Variant Dim l As Long 显示打开文件夹对话框 With Application。FileDialog（msoFileDialogFolderPicker).Show If.SelectedItems。Co

31、unt=0 Then Exit Sub 未选择文件夹 strFolder=.SelectedItems(1）End With 获取文件夹中的所有文件列表 varFileList=fcnGetFileList(strFolder)If Not IsArray（varFileList）Then MsgBox”未找到文件”，vbInformation Exit Sub End If 获取文件的详细信息，并放到数组中 ReDim myResults(0 To UBound(varFileList)+1,0 To 5)myResults(0，0）=”文件名”myResults（0,1）=”大小(字节）”

32、myResults(0，2）=”创建时间”myResults(0,3）=修改时间 myResults(0,4)=访问时间 myResults(0，5)=完整路径 Set FSO=CreateObject(Scripting。FileSystemObject”)For l=0 To UBound(varFileList)Set myFile=FSO.GetFile（CStr（varFileList（l)）myResults(l+1，0）=CStr(varFileList（l）)myResults（l+1,1）=myFile.Size myResults（l+1,2)=myFile.DateCre

33、ated myResults（l+1，3)=myFile.DateLastModified myResults(l+1,4)=myFile.DateLastAccessed myResults（l+1,5)=myFile.Path Next l fcnDumpToWorksheet myResults Set myFile=Nothing Set FSO=Nothing End Sub Private Function fcnGetFileList(ByVal strPath As String,Optional strFilter As String)As Variant 如果文件夹中包含文

34、件返回一个二维数组,否则返回 False Dim f As String Dim i As Integer Dim FileList（)As String If strFilter=”Then strFilter=*.*”Select Case Right(strPath,1）Case”,/”strPath=Left$（strPath，Len(strPath)1)End Select ReDim Preserve FileList(0)f=Dir(strPath&strFilter）Do While Len(f)0 ReDim Preserve FileList(i）As String Fil

35、eList（i）=f i=i+1 f=Dir$（)Loop If FileList（0)0 Then For i=1 To。FoundFiles。Count Worksheets（sheet3”).Cells(i，2）。Value=.FoundFiles(i）Dim fs,f，s Set fs=CreateObject（Scripting。FileSystemObject）Set f=fs.GetFile(.FoundFiles(i）s=”Created：&f。DateCreated Worksheets（sheet3”）。Cells（i，3）。Value=s Set f=Nothing Se

36、t fs=Nothing Next i Else MsgBox”no file found。”End If End With End Sub 8.VBA 代码调用浏览文件夹对话框的几种方法 200905-25 15：24 1、使用 API 方法【类型声明】Private Type BROWSEINFO hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End T

37、ype【API 声明】Private Declare Function SHGetPathFromIDList Lib shell32.dll”_ Alias SHGetPathFromIDListA”(ByVal pidl As Long,_ ByVal pszPath As String)As Long Private Declare Function SHBrowseForFolder Lib shell32.dll”_ Alias”SHBrowseForFolderA（lpBrowseInfo As BROWSEINFO)As Long Private Declare Function

38、 lstrcat Lib”kernel32”_ Alias”lstrcatA”（ByVal lpString1 As String,_ ByVal lpString2 As String)As Long Private Declare Function OleInitialize Lib”ole32。dll _ （lp As Any)As Long Private Declare Sub OleUninitialize Lib ole32”(）Private Const BIF_USENEWUI=&H40 Private Const MAX_PATH=260【自定义函数】Public Func

39、tion GetFolder_API（sTitle As String，Optional vFlags As Variant)As String Dim lpIDList As Long Dim sBuffer As String Dim BInfo As BROWSEINFO If IsMissing(vFlags）Then vFlags=BIF_USENEWUI Call OleInitialize（ByVal 0&）With BInfo。lpszTitle=lstrcat（sTitle，”)。ulFlags=vFlags End With lpIDList=SHBrowseForFold

40、er（BInfo）If(lpIDList)Then sBuffer=Space（MAX_PATH）SHGetPathFromIDList lpIDList,sBuffer sBuffer=Left(sBuffer，InStr(sBuffer,vbNullChar）-1）If sBuffer ”Then GetFolder_API=sBuffer End If Call OleUninitialize End Function 【使用方法】Sub Test(）MsgBox GetFolder_API(选择文件夹）End Sub 2、使用 Shell。Application 方法 Sub GetF

41、loder_Shell（)Set objShell=CreateObject（”Shell。Application)Set objFolder=objShell.BrowseForFolder（0，”选择文件夹，0,0）If Not objFolder Is Nothing Then MsgBox objFolder.self。path End If Set objFolder=Nothing Set objShell=Nothing End Sub 3、使用 FileDialog 方法 Sub GetFloder_FileDialog()Dim fd As FileDialog Set fd

42、=Application.FileDialog(msoFileDialogFolderPicker）If fd。Show=-1 Then MsgBox fd。SelectedItems（1）Set fd=Nothing End Sub 以上方法在 WINXP+OFFICE2003 中测试通过 Excel VBA 选择目标文件夹方法 200904-13 08：49 9.用 VBA 选择目标文件夹 几种实现代码：1。FileDialog 属性 Sub Sample1（)With Application.FileDialog(msoFileDialogFolderPicker)If。Show=Tru

43、e Then MsgBox.SelectedItems（1）txtFolder.Text=.SelectedItems(1）End If End With End Sub 2。shell 方法 Sub Sample2（)Dim Shell,myPath Set Shell=CreateObject(Shell。Application”)Set myPath=Shell.BrowseForFolder（O0，”请选择文件夹,H1+&H10,”G:”）If Not myPath Is Nothing Then MsgBox myPath。Items。Item.Path Set Shell=Noth

44、ing Set myPath=Nothing End Sub 3.API 方法 Declare Function SHGetPathFromIDList Lib”shell32。dll”Alias SHGetPathFromIDListA _(ByVal pidl As Long,ByVal pszPath As String)As Long Declare Function SHBrowseForFolder Lib shell32。dll”Alias SHBrowseForFolderA”_（lpBrowseInfo As BROWSEINFO)As Long Declare Functi

45、on GetDesktopWindow Lib”user32”()As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub Sample3（)Dim buf As String buf=GetFolder(”请选择文件夹）If buf=”Then Exit Sub MsgBox buf End S

46、ub Function GetFolder（Optional Msg)As String Dim bInfo As BROWSEINFO，pPath As String Dim R As Long,X As Long,pos As Integer bInfo。pidlRoot=0&bInfo.lpszTitle=Msg bInfo。ulFlags=&H1 X=SHBrowseForFolder(bInfo)pPath=Space（512）R=SHGetPathFromIDList（ByVal X,ByVal pPath）If R Then pos=InStr（pPath，Chr(0)GetFo

47、lder=Left（pPath,pos-1）Else GetFolder=”End If End Function 10.VBA 代码调用浏览文件夹对话框的几种方法 1、使用 API 方法 【类型声明】Private Type BROWSEINFO hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type 【API 声明】Private Declare

48、 Function SHGetPathFromIDList Lib shell32.dll _ Alias”SHGetPathFromIDListA”（ByVal pidl As Long，_ ByVal pszPath As String)As Long Private Declare Function SHBrowseForFolder Lib shell32.dll”_ Alias”SHBrowseForFolderA（lpBrowseInfo As BROWSEINFO）As Long Private Declare Function lstrcat Lib”kernel32”_ Al

49、ias lstrcatA”(ByVal lpString1 As String，_ ByVal lpString2 As String）As Long Private Declare Function OleInitialize Lib”ole32.dll”_(lp As Any)As Long Private Declare Sub OleUninitialize Lib”ole32”（）Private Const BIF_USENEWUI=H40 Private Const MAX_PATH=260 【自定义函数】Public Function GetFolder_API（sTitle A

50、s String,Optional vFlags As Variant）As String Dim lpIDList As Long Dim sBuffer As String Dim BInfo As BROWSEINFO If IsMissing（vFlags)Then vFlags=BIF_USENEWUI Call OleInitialize(ByVal 0&)With BInfo。lpszTitle=lstrcat(sTitle,”）.ulFlags=vFlags End With lpIDList=SHBrowseForFolder（BInfo）If（lpIDList）Then s