My workplace is rolling out some large updates for Microsoft office. I'm trying to set up a VBA macro to run on everyone's computer to create a new folder with copies of Normal.dotm so that if (God forbid) something goes wrong we can restore the Normal.dotm. This is important because EVERYONE has a different ribbon layout and different macros and settings that we don't want lost.
My problem is I have a macro that is functionally fine, however when i try it on the Normal.dotm it gives the Permission Denied error because the FileCopy funtion cant work on Normal.dotm.
Code:
Private Sub CopyFiles_Click()
sUserName = Environ$("username")
Dim BackupDir As String
BackupDir = "C:\Users\" + sUserName + "\Desktop\Backup for Normal - DO NOT DELETE"
If FileFolderExists(BackupDir) Then
Else
MkDir BackupDir
End If
If FileFolderExists("C:\Users\" + sUserName + "\AppData\Roaming\Microsoft\Templates\Normal.dotm") Then
FileCopy "C:\Users\" + sUserName + "\AppData\Roaming\Microsoft\Templates\Normal.dotm", (BackupDir + "\Normal.dotm")
End If
End Sub
I have a function for "FileFolderExists" i just didn't include it to save space (it works fine)
My question is, is there any way to work around this (Been searching for a while and have come up empty handed), or is there a better way to do this?
Try this VBScript (Not VBA)
Dim sUserName
sUserName = CreateObject("WScript.Network").UserName
Dim BackupDir
BackupDir = "C:\Users\" + sUserName + "\Desktop\Backup for Normal - DO NOT DELETE"
dim filesys
set filesys=CreateObject("Scripting.FileSystemObject")
on error resume next
filesys.CreateFolder BackupDir
on error goto 0
filesys.CopyFile "C:\Users\" & sUserName & "\AppData\Roaming\Microsoft\Templates\Normal.dotm", (BackupDir & "\Normal.dotm")
Related
I have a list of file names in a worksheet. I want to read a name, find the actual file, rename it and move on to the next name.
The 1st part, retrieving the name from the worksheet and modifying it to the new name is not a problem. The problem is assigning the new name to the file.
The Name function does not work because the files are on a different drive. I also tried Scripting.FileSystemObject.
The code runs but no change is made.
Here is the code I used...
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set f = fso.GetFile(fOldName)
If Not Err = 53 Then 'File not found
'Rename file
f.Name = fNewName
End If
Did I make a code mistake I'm not seeing? Should I be using/doing something else?
Finding info on VBA and/or VB6 is getting pretty rare these days.
BTW. This is for Excel 2016.
Tks
If there was no misunderstanding...
FSO... it's bad in any case. It's just a bugsful API wrapper, written with a left chicken paw.
There are pure VB & API for more sophisticated cases.
No external libs & objects:
Public Sub sp_PrjFilMov()
Dim i As Byte
Dim sNam$, sExt$, sPthSrc$, sPthTgt$, sDir$
sPthSrc = "V:\"
sPthTgt = "R:\"
sNam = "Empty_"
sExt = ".dmy" ' dummy
For i = 1 To 5 ' create set of files for test
Call sx_CrtFil(i, sPthSrc, sNam, sExt)
Next
sDir = Dir(sPthSrc & "*" & sExt, vbNormal) ' lookup for our files ..
Do
'Debug.Print sDir
Select Case LenB(sDir)
Case 0
Exit Do ' *** EXIT DO
Case Else
Call sx_MovFil(sPthSrc, sDir, sPthTgt) ' .. & move them to another disk
sDir = Dir
End Select
Loop
Stop
End Sub
Private Sub sx_CrtFil(pNmb As Byte, pPth$, pNam$, pExt$)
Dim iFilNmb%
Dim sFilNam$
sFilNam = pPth & pNam & CStr(pNmb) & pExt
iFilNmb = FreeFile
Open sFilNam For Output As #iFilNmb
Close #iFilNmb
End Sub
Private Sub sx_MovFil(pPnmSrc$, pFnm$, pPthTgt$)
Dim sSrcPne$
sSrcPne = pPnmSrc & pFnm
'Debug.Print "Move " & sSrcPne & " --> " & pPthTgt
Call FileCopy(sSrcPne, pPthTgt & pFnm)
Call Kill(sSrcPne)
End Sub
'
The following code runs well if I have administrator permissions. But it doesn't work at all for a user.
Sub CATMain()
On Error Resume Next
Dim strpath As String
strpath = CATIA.FileSelectionBox("Select file", "*.xlsx",
CatFileSelectionModeOpen)
End Sub
I think CATIA.FileSelectionBox() works fine in CATScript so I was thinking in run a CATScript with Application.ExecuteScript(). When I try to do it another error pops up "Function or interface marked as restricted...". Can anyone give me an alternative method? Would be very much appreciated.
Ok, I found my answer. Thanks for letting me post my question in here. Next, I post a code that works just fine. The only thing that remains incomplete is that I can not add filters for types of files like *.CATParts or *.CATProducts in this code. But it works for me already.
Function SelectFile( )
' File Browser via HTA
' Author: Rudi Degrande, modifications by Denis St-Pierre and Rob van der
Woude
' Features: Works in Windows Vista and up (Should also work in XP).
' Fairly fast.
' All native code/controls (No 3rd party DLL/ XP DLL).
' Caveats: Cannot define default starting folder.
' Uses last folder used with MSHTA.EXE stored in Binary in
[HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\ComDlg32].
' Dialog title says "Choose file to upload".
' Source: https://social.technet.microsoft.com/Forums/scriptcenter/en-
US/a3b358e8-15ae-4ba3-bca5-ec349df65ef6/windows7-vbscript-open-file-dialog-
box-fakepath?forum=ITCG
Dim objExec, strMSHTA, wshShell
SelectFile = ""
' For use in HTAs as well as "plain" VBScript:
strMSHTA = "mshta.exe ""about:" & "<" & "input type=file id=FILE>" _
& "<" & "script>FILE.click();new
ActiveXObject('Scripting.FileSystemObject')" _
&
".GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);" & "<" &
"/script>"""
' For use in "plain" VBScript only:
' strMSHTA = "mshta.exe ""about:<input type=file id=FILE>" _
' & "<script>FILE.click();new
ActiveXObject('Scripting.FileSystemObject')" _
' &
".GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);
</script>"""
Set wshShell = CreateObject( "WScript.Shell" )
Set objExec = wshShell.Exec( strMSHTA )
SelectFile = objExec.StdOut.ReadLine( )
Set objExec = Nothing
Set wshShell = Nothing
End Function
Kind regards
I would like to export/ maintain/ manage a text file backup of modules in my personal macro workbook personal.xlsb using VBA.
I cannot find an object library which refers to the modules themselves on msdn. Could someone point me in the right direction on this please?
Using Excel 2013.
You need to add Visual Basic for Application Extensibility X.X reference; or:
Sub load_reference_1()
ThisWorkbook.VBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 3
end sub
Sub Load_reference_2()
ThisWorkbook.VBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
end sub
Example:
Sub Macromodule_copy1()
ThisWorkbook.VBProject.VBComponents("Macroos").Export "E:\Macroos.bas"
With Workbooks.Add
.VBProject.VBComponents.Import "E:\Macroos.bas"
End With
End Sub
Further examples and source: Snb-Vba -awesome examples!-
I do exactly this, with my personal.xlsb and also with other macro workbooks.
I save the text files into a "VBA" subdirectory and put them into version control to keep track of the changes.
I was inspired by Mass importing modules & references in VBA which references https://www.rondebruin.nl/win/s9/win002.htm
I have a module called WriteBas containing this code:
Attribute VB_Name = "WriteBas"
Option Explicit
Sub WriteAllBas()
' Write all VBA modules as .bas files to the directory of ThisWorkbook.
' Implemented to make version control work smoothly for identifying changes.
' Designed to be called every time this workbook is saved,
' if code has changed, then will show up as a diff
' if code has not changed, then file will be same (no diff) with new date.
' Following https://stackoverflow.com/questions/55956116/mass-importing-modules-references-in-vba
' which references https://www.rondebruin.nl/win/s9/win002.htm
Dim cmp As VBComponent, cmo As CodeModule
Dim fn As Integer, outName As String
Dim sLine As String, nLine As Long
Dim dirExport As String, outExt As String
Dim fileExport As String
On Error GoTo MustTrustVBAProject
Set cmp = ThisWorkbook.VBProject.VBComponents(1)
On Error GoTo 0
dirExport = ThisWorkbook.Path + Application.PathSeparator + "VBA" + Application.PathSeparator
For Each cmp In ThisWorkbook.VBProject.VBComponents
Select Case cmp.Type
Case vbext_ct_ClassModule:
outExt = ".cls"
Case vbext_ct_MSForm
outExt = ".frm"
Case vbext_ct_StdModule
outExt = ".bas"
Case vbext_ct_Document
Set cmo = cmp.CodeModule
If Not cmo Is Nothing Then
If cmo.CountOfLines = cmo.CountOfDeclarationLines Then ' Ordinary worksheet or Workbook, no code
outExt = ""
Else ' It's a Worksheet or Workbook but has code, export it
outExt = ".cls"
End If
End If ' cmo Is Nothing
Case Else
Stop ' Debug it
End Select
If outExt <> "" Then
fileExport = dirExport + cmp.name + outExt
If Dir(fileExport) <> "" Then Kill fileExport ' From Office 365, Export method does not overwrite existing file
cmp.Export fileExport
End If
Next cmp
Exit Sub
MustTrustVBAProject:
MsgBox "Must trust VB Project in Options, Trust Center, Trust Center Settings ...", vbCritical + vbOKOnly, "WriteAllBas"
End Sub
and in my ThisWorkbook object, the BeforeSave event handler calls it each time the workbook is saved.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
WriteAllBas
End Sub
There's a second or two of overhead each time the workbook is saved.
Note: Under Office 2016 and earlier versions I didn't need to delete (Kill) the text file before exporting, but under Office 365 the Export method fails if the file exists.
I just save a date/timestamped copy of PERSONAL.xlsb to a backup drive location using the following code.
Sub PersonalBckup()
Const dstBak As String = "H:\PERSONAL MACROS\" 'change path to suit
Const dstBak2 As String = "D:\PERSONAL Macros\"
On Error Resume Next 'if either of the drives are not present, skip error.
Application.DisplayAlerts = False 'turn off warning popups
With Workbooks("PERSONAL.xlsb") 'name of your PERSONAL.xlsb file
.SaveCopyAs dstBak & "PERSONAL" & " as of " & Format(Now(), "YYYYMMDD_hhmmAMPM") & ".xlsb"
.SaveCopyAs dstBak2 & "PERSONAL" & " as of " & Format(Now(), "YYYYMMDD_hhmmAMPM") & ".xlsb"
.Save
End With
Application.DisplayAlerts = True 'Turn on warning popups
The backed-up file is saved with a date/timestamp: "PERSONAL as of 20180512_0136PM.xlsb"
I know this doesn't exactly answer the question, but perhaps it's still helpful. You can easily save all modules into a pdf by rigth clicking the modules folder and clicking print (and then clicking setup to change to print to pdf) . This won't give you a specific exported file that can be easily imported back in per se, but it keeps a safely saved file that you can always go back and reference should anything go wrong in your code. There's probably a way to automate this (or at least make it a one-time click when you save), but I haven't figured that out yet.
I'm in the position of needing to make a bunch of folders for my PC so I decided to turn it in to a coding task. I've managed to make it so the user types in the location they want the folders to go into as well as each line of the other text box being the title for a new folder.
Here's the problem. I ideally would like to put multiple folders inside each folder without running the program again. The textbox would look something like this and would result in file 1,2 in folderA and file 3,4 in folderB;
FolderA
File 1
File 2
FolderB
File 3
File 4
Here is the code I've done so far.
Dim Address As String = TextBox1.Text
For i As Integer = 0 To RichTextBox1.Lines.Count - 1
My.Computer.FileSystem.CreateDirectory(Address + (RichTextBox1.Lines(i)))
Next
Do you know what I would have to add to my code so that it includes sub-folders?
(I haven't been learning long so I'm sorry if the answer is really obvious.)
#punintentional
The code below will do exactly what you asked for. You HAVE to make sure you have a reference set to the Microsoft Office Object Library. You do this by going to Tools>References and find the appropriate on. I designed the below code with Microsoft Office 12 Object Library. If you are using Office 2010, I think the Reference will be for Microsoft Office 14 Object Library.
Option Explicit
Public Sub DirectorySelect()
Dim diaFileDialog As FileDialog
Dim blDirSelected As Boolean
Dim strBaseDirectory As String
Dim strA_Dir As String
Dim StrB_Dir As String
' set up a MS Office file dialog box to select a folder/directory
Set diaFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With diaFileDialog
.AllowMultiSelect = False ' user may only select one base folder
.Title = "Select the base director" ' title of the dialog box
blDirSelected = .Show ' the .show method will return false if the user does not select a directory
If blDirSelected = True Then ' a directory was selected
strBaseDirectory = .SelectedItems(1) ' put the directory into a variable
strBaseDirectory = strBaseDirectory & "\" ' the returned directory needs a trailing backslash
' These steps will jump to the other sub procedure to make the desired folders
MakeNewDir _
BaseDirectory:=strBaseDirectory, _
AddDirectory:="FolderA"
strA_Dir = strBaseDirectory & "FolderA" & "\"
MakeNewDir _
BaseDirectory:=strA_Dir, _
AddDirectory:="Folder1"
MakeNewDir _
BaseDirectory:=strA_Dir, _
AddDirectory:="Folder2"
MakeNewDir _
BaseDirectory:=strBaseDirectory, _
AddDirectory:="FolderB"
StrB_Dir = strBaseDirectory & "FolderB" & "\"
MakeNewDir _
BaseDirectory:=StrB_Dir, _
AddDirectory:="Folder3"
MakeNewDir _
BaseDirectory:=StrB_Dir, _
AddDirectory:="Folder4"
End If
End With
End Sub
Public Sub MakeNewDir(ByVal BaseDirectory As String, ByVal AddDirectory As String)
If Dir(BaseDirectory, vbDirectory) = vbNullString Then
MkDir BaseDirectory
End If
If Right(BaseDirectory, 1) <> "\" Then
BaseDirectory = BaseDirectory & "\"
End If
MkDir BaseDirectory & AddDirectory
End Sub
I'd like to be able to source control my Excel spreadsheet's VBA modules (currently using Excel 2003 SP3) so that I can share and manage the code used by a bunch of different spreadsheets - and therefore I'd like to re-load them from files when the spreadsheet is opened.
I've got a module called Loader.bas, that I use to do most of the donkey work (loading and unloading any other modules that are required) - and I'd like to be able to load it up from a file as soon as the spreadsheet is opened.
I've attached the following code to the Workbook_Open event (in the ThisWorkbook class).
Private Sub Workbook_Open()
Call RemoveLoader
Call LoadLoader
End Sub
Where RemoveLoader (also within the ThisWorkbook class) contains the following code:
Private Sub RemoveLoader()
Dim y As Integer
Dim OldModules, NumModules As Integer
Dim CompName As String
With ThisWorkbook.VBProject
NumModules = ThisWorkbook.VBProject.VBComponents.Count
y = 1
While y <= NumModules
If .VBComponents.Item(y).Type = 1 Then
CompName = .VBComponents.Item(y).Name
If VBA.Strings.InStr(CompName, "Loader") > 0 Then
OldModules = ThisWorkbook.VBProject.VBComponents.Count
.VBComponents.Remove .VBComponents(CompName)
NumModules = ThisWorkbook.VBProject.VBComponents.Count
If OldModules - NumModules = 1 Then
y = 1
Else
MsgBox ("Failed to remove " & CompName & " module from VBA project")
End If
End If
End If
y = y + 1
Wend
End With
End Sub
Which is probably a bit overcomplicated and slightly crude - but I'm trying everything I can find to get it to load the external module!
Often, when I open the spreadsheet, the RemoveLoader function finds that there's a "Loader1" module already included in the VBA project that it is unable to remove, and it also fails to load the new Loader module from the file.
Any ideas if what I'm trying to do is possible? Excel seems very fond of appending a 1 to these module names - either when loading or removing (I'm not sure which).
There is an excellent solution to the vba version control problem here: https://github.com/hilkoc/vbaDeveloper
The nice part about this is that it exports your code automatically, as soon as you save your workbook. Also, when you open a workbook, it imports the code.
You don't need to run any build scripts or maven commands and you don't need to make any changes to your workbooks. It works for all.
It has also solved the import problem where modules such as ModName are being imported as ModName1 into a duplicate module. The importing works as it should, even when doing it multiple times.
As a bonus, it comes with a simple code formatter, that allows you to format your vba code as you write it within the VBA Editor.
Look at the VBAMaven page. I have a homegrown solution that uses the same concepts. I have a common library with a bunch of source code, an ant build and an 'import' VB script. Ant controls the build, which takes a blank excel file and pushes the needed code into it. #Mike is absolutely correct - any duplicate module definitions will automatically have a number appended to the module name. Also, class modules (as in Sheet and ThisWorkbook) classes require special treatment. You can't create those modules, you have to read the input file and write the buffer into the appropriate module. This is the VB script I currently use to do this. The section containing # delimited text (i.e. #build file#) are placeholders - the ant build replaces these tags with meaningful content. It's not perfect, but works for me.
''
' Imports VB Basic module and class files from the src folder
' into the excel file stored in the bin folder.
'
Option Explicit
Dim pFileSystem, pFolder, pPath
Dim pShell
Dim pApp, book
Dim pFileName
pFileName = "#build file#"
Set pFileSystem = CreateObject("Scripting.FileSystemObject")
Set pShell = CreateObject("WScript.Shell")
pPath = pShell.CurrentDirectory
If IsExcelFile (pFileName) Then
Set pApp = WScript.CreateObject ("Excel.Application")
pApp.Visible = False
Set book = pApp.Workbooks.Open(pPath & "\build\" & pFileName)
Else
Set pApp = WScript.CreateObject ("Word.Application")
pApp.Visible = False
Set book = pApp.Documents.Open(pPath & "\build\" & pFileName)
End If
'Include root source folder code if no args set
If Wscript.Arguments.Count = 0 Then
Set pFolder = pFileSystem.GetFolder(pPath & "\src")
ImportFiles pFolder, book
'
' Get selected modules from the Common Library, if any
#common path##common file#
Else
'Add code from subdirectories of src . . .
If Wscript.Arguments(0) <> "" Then
Set pFolder = pFileSystem.GetFolder(pPath & "\src\" & Wscript.Arguments(0))
ImportFiles pFolder, book
End If
End If
Set pFolder = Nothing
Set pFileSystem = Nothing
Set pShell = Nothing
If IsExcelFile (pFileName) Then
pApp.ActiveWorkbook.Save
Else
pApp.ActiveDocument.Save
End If
pApp.Quit
Set book = Nothing
Set pApp = Nothing
'' Loops through all the .bas or .cls files in srcFolder
' and calls InsertVBComponent to insert it into the workbook wb.
'
Sub ImportFiles(ByVal srcFolder, ByVal obj)
Dim fileCollection, pFile
Set fileCollection = srcFolder.Files
For Each pFile in fileCollection
If Right(pFile, 3) = "bas _
Or Right(pFile, 3) = "cls _
Or Right(pFile, 3) = "frm Then
InsertVBComponent obj, pFile
End If
Next
Set fileCollection = Nothing
End Sub
'' Inserts the contents of CompFileName as a new component in
' a Workbook or Document object.
'
' If a class file begins with "Sheet", then the code is
' copied into the appropriate code module 1 painful line at a time.
'
' CompFileName must be a valid VBA component (class or module)
Sub InsertVBComponent(ByVal obj, ByVal CompFileName)
Dim t, mName
t = Split(CompFileName, "\")
mName = Split(t(UBound(t)), ".")
If IsSheetCodeModule(mName(0), CompFileName) = True Then
ImportCodeModule obj.VBProject.VBComponents(mName(0)).CodeModule, _
CompFileName
Else
If Not obj Is Nothing Then
obj.VBProject.VBComponents.Import CompFileName
Else
WScript.Echo "Failed to import " & CompFileName
End If
End If
End Sub
''
' Imports the code in the file fName into the workbook object
' referenced by mName.
' #param target destination CodeModule object in the excel file
' #param fName file system file containing code to be imported
Sub ImportCodeModule (ByVal target, ByVal fName)
Dim shtModule, code, buf
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Set buf = fso.OpenTextFile(fName, ForReading, False, TristateUseDefault)
buf.SkipLine
code = buf.ReadAll
target.InsertLines 1, code
Set fso = Nothing
End Sub
''
' Returns true if the code module in the file fName
' appears to be a code module for a worksheet.
Function IsSheetCodeModule (ByVal mName, ByVal fName)
IsSheetCodeModule = False
If mName = "ThisWorkbook" Then
IsSheetCodeModule = False
ElseIf Left(mName, 5) = "Sheet" And _
IsNumeric(Mid (mName, 6, 1)) And _
Right(fName, 3) = "cls Then
IsSheetCodeModule = True
End If
End Function
''
' Returns true if fName has a xls file extension
Function IsExcelFile (ByVal fName)
If Right(fName, 3) = "xls" Then
IsExcelFile = True
Else
IsExcelFile = False
End If
End Function
I've been working on exactly this for months. I think I figured it out.
If the VB Project is trying to remove a module containing something in the call stack, it delays the removal until the call stack pops the module being replaced.
To avoid a module being in the call stack, launch your code with Application.OnTime
Private Sub Workbook_Open()
'WAS: module_library (1)
Application.OnTime (Now + TimeValue("00:00:01")), "load_library_kicker_firstiter"
End Sub
If you are self-healing your code like I am, you'll also have to launch your code that overwrites the 'calling' code with that same strategy.
I did not perform extensive testing yet, I am in total celebration mode, but this gets me extremely close to straightforward 99.9% self-healing code within a standalone .xls file without any other tricks
Usually the "Loader1" thing happens when Excel is asked to import a module and a module already exists with the same name. So if you import "Loader", then load it again and you'll get "Loader1". This would be because Excel doesn't know (or maybe just doesn't care) if it's really the same thing or a new chunk of functionality that just happens have the same module name, so it imports it anyway.
I can't think of a perfect solution, but I think I'd be inclined to try putting the load/unload logic in an add-in - that Workbook_Open thing looks a little vulnerable and having it in all workbooks is going to be a huge pain if the code ever needs to change (never say never). The XLA logic might be more complex (trickier to trap the necessary events, for one thing) but at least it'll only exist in one place.
Can't leave comment to comment
There is an excellent solution to the vba version control problem
here: https://github.com/hilkoc/vbaDeveloper
About saving custom VBAProjects using this XLAM.
Try this in Build.bas:
'===============
Public Sub testImport()
Dim proj_name As String
Dim vbaProject As Object
'proj_name = "VBAProject"
'Set vbaProject = Application.VBE.VBProjects(proj_name)
Set vbaProject = Application.VBE.ActiveVBProject
proj_name = vbaProject.name
Build.importVbaCode vbaProject
End Sub
'===============
Public Sub testExport()
Dim proj_name As String
Dim vbaProject As Object
'proj_name = "VBAProject"
'Set vbaProject = Application.VBE.VBProjects(proj_name)
Set vbaProject = Application.VBE.ActiveVBProject
proj_name = vbaProject.name
Build.exportVbaCode vbaProject
End Sub
'===============
This will export/import Active VBA Project.
The following is an easy-to-implement answer if you don't need to export your VBA code automatically. Just Call the following sub and it will export (as text) the VBA code of the current active workbook in a subfolder named "VC_nameOfTheWorkBook". If your project is a .xlam, you need to temporarily set the IsAddin property to false. Then you can easily add the new subfolder to Git. It is a slight modification of the code found here made by Steve Jansen. For a more complete solution see Ron de Bruin post.
You need to set a reference to "Microsoft Visual Basic For Applications Extensibility 5.3" and to "Microsoft Scripting Runtime" in the VBE Editor.
Public Sub ExportVisualBasicCode()
Const Module = 1
Const ClassModule = 2
Const Form = 3
Const Document = 100
Const Padding = 24
Dim VBComponent As Object
Dim path As String
Dim directory As String
Dim extension As String
Dim fso As New FileSystemObject
directory = ActiveWorkbook.path & "\VC_" & fso.GetBaseName(ActiveWorkbook.Name)
If Not fso.FolderExists(directory) Then
Call fso.CreateFolder(directory)
End If
Set fso = Nothing
For Each VBComponent In ActiveWorkbook.VBProject.VBComponents
Select Case VBComponent.Type
Case ClassModule, Document
extension = ".cls"
Case Form
extension = ".frm"
Case Module
extension = ".bas"
Case Else
extension = ".txt"
End Select
On Error Resume Next
Err.Clear
path = directory & "\" & VBComponent.Name & extension
Call VBComponent.Export(path)
If Err.Number <> 0 Then
Call MsgBox("Failed to export " & VBComponent.Name & " to " & path, vbCritical)
Else
Debug.Print "Exported " & Left$(VBComponent.Name & ":" & Space(Padding), Padding) & path
End If
On Error GoTo 0
Next
End Sub