使用Excel的VBProject可以导出文件中的VBA代码，但是有的文件有宏密码保护，导出就会报错。在知道密码的前提下可以打开Excel后用代码自动填写密码，然后导出。
刚开始我尝试使用VBA去实现，但是VBA是寄生于Excel运行的，会对填写密码造成影响，于是改用VBS实现。
把VBS放在要导出的文件夹下运行，遍历该路径下所有的Excel文件，并在放置VBS的路径生成Excel文件名的文件夹，文件夹存放导出的内容。有密码就输入密码，没有密码直接点击确定。
代码如下：
Dim otpth,gfolder,fso,newbk,pswdDim a,paswd,ws,oExcel,errTestpsw = InputBox("Input your Password","Password")If Trim(psw) <> "" Or Not IsEmpty(psw)Thenpswd = Trim(psw)Call vbaexp()End IfSub vbaexp()Set fso = CreateObject("scripting.filesystemobject")Set ws = CreateObject("wscript.shell")Set oExcel= CreateObject( "Excel.Application" )oExcel.visible = Trueotpth= ws.CurrentDirectoryepath= otpthmkexp (epath)oExcel.quitIf Err.Number = 0 Then MsgBox ("success !!")End SubFunction mkexp(epath)Set gfolder = fso.getfolder(epath)For Each subgfo In gfolder.subfoldersmkexp (subgfo.Path)NextFor Each sfil In gfolder.Filessfinm = Trim(sfil.Name)If InStr(sfinm, ".") > 0 And Mid(sfinm,1,2) <> "~$"Thenubsp = UBound(Split(sfinm, "."))houz = Trim(Split(sfinm, ".")(ubsp))houzhui = UCase(houz)If houzhui = "XLS" Or houzhui = "XLSX" Or houzhui = "XLSM" ThenoExcel.Workbooks.Open sfilSet newbk = oExcel.Workbooks(sfil.Name)If pswd <> "" ThenIf newbk.VBProject.Protection = 1 Thennewbk.Activatews.SendKeys "%{F11}"ws.SendKeys "%T"ws.SendKeys "E"ws.SendKeys pswdws.SendKeys "{ENTER}"wscript.sleep 1000ws.SendKeys "%{F4}"ws.SendKeys "%{F4}"End IfEnd IfOn Error Resume NextSet errTest = newbk.VBProject.VBComponentsIf Err.Number <> 0 Thennewbk.Close FalseMsgBox(sfinm & " invalid password !!")Elsenewfol = otpth & "\" & Replace(sfinm, "." & houz, "")If Not fso.folderexists(newfol) Thenfso.createfolder (newfol)End IfFor Each vbpj In newbk.VBProject.VBComponentsexpfinm = ""Select Case vbpj.TypeCase 1 'vbext_ct_StdModule case 1expfinm = vbpj.Name & ".bas"Case 2 'vbext_ct_ClassModule case 2expfinm = vbpj.Name & ".cls"Case 3 'vbext_ct_MSForm case 3expfinm = vbpj.Name & ".frm"Case 100 'vbext_ct_Document case 100If vbpj.Name <> "ThisWorkbook" ThenFor Each sht In newbk.WorksheetsIf sht.CodeName = vbpj.Name Thenexpfinm = sht.Name & ".txt"End IfNextElseexpfinm = vbpj.Name & ".txt"End IfEnd Selectnewbk.VBProject.VBComponents(vbpj).Export newfol & "\" & expfinmNextErr.Clearnewbk.Close FalseEnd IfEnd IfEnd IfNextEnd Function
