excel_export_code.vbs

' ========================================================
'
' Author : Christophe Avonture
' Date	: June 2018
'
' VBScript that will extract all the VBA code from a workbook
' (classes, forms, modules and worksheet code) and will export
' these objects on the filesystem as text file.
'
' Export the ribbon (if there is one), manifest and icons.
'
' By ussing the script on f.i; the file called c:\repo\cavo.xlam,
' this script will create the folder c:\repo\src\cavo.xlam\ and, there,
' one file for each classes, forms, modules and sheets with code.
'
' The idea is : make it easy to export the code for a versioning tool
' like GitHub or other tools
'
' Code for the extraction is based on vbaDeveloper
' https://github.com/hilkoc/vbaDeveloper
'
' Changes
' =======
'
' 2019-04-24 - Automatically export the VBA code of the project but
'				now ask before exporting anything else (like addins)
'
' ========================================================

Option Explicit

Const bVerbose = True

' Location, if installed, of 7-zip. Will make the export of the
' ribbon manifest faster
Const ZipProgram = "C:\Program Files\7-Zip\7z.exe"

Const vbext_ct_StdModule = 1
Const vbext_ct_ClassModule = 2
Const vbext_ct_MSForm = 3
Const vbext_ct_Document = 100

' https://ss64.com/vb/popup.html
Const popup_type_YesNo = 4
Const popup_answer_Yes = 6
Const popup_answer_No = 7

Class clsFiles

	Dim objFSO, objFile

	Private bVerbose

	Public Property Let verbose(bYesNo)
		bVerbose = bYesNo
	End Property

	Private Sub Class_Initialize()
		bVerbose = False
		Set objFSO = CreateObject("Scripting.FileSystemObject")
	End Sub

	Private Sub Class_Terminate()
		Set objFSO = Nothing
	End Sub

	Public Function Exists(ByVal sFileName)
		Exists = objFSO.FileExists(sFileName)
	End Function

	Public Function Delete(ByVal sFileName)
		Delete = objFSO.DeleteFile(sFileName)
	End Function

	Public Function Rename(ByVal sFileName, ByVal sNewName)

		If (Exists(sNewName)) Then
			Delete(sNewName)
		End If

		objFSO.MoveFile sFileName, sNewName

		Rename = Exists(sNewName)

	End Function

	' --------------------------------------------------
	' Return the file extension (f.i. "accdb")
	' --------------------------------------------------
	Public Function GetExtensionName(ByVal sFileName)
		GetExtensionName = objFSO.GetExtensionName(sFileName)
	End Function

	' --------------------------------------------------
	' Return only the file name (f.i. "db1")
	' --------------------------------------------------
	Public Function GetBaseName(ByVal sFileName)
		GetBaseName = objFSO.GetBaseName(sFileName)
	End Function

	' --------------------------------------------------
	' Return the folder where the file is stored (f.i. c:\temp)
	' --------------------------------------------------
	Public Function GetParentFolderName(ByVal sFileName)

		Dim sPath
		Dim objShell

		sPath = ""

		If (Exists(sFileName)) Then

			sPath = objFSO.GetParentFolderName(sFileName)

			' sPath is empty when sFileName was just a filename
			' like f.i. "workbook.xlsx". So, in that case, get the current
			' folder and concatenate
			If (sPath = "") Then
				Set objShell = WScript.CreateObject("WScript.Shell")
				sPath = objShell.CurrentDirectory
				Set objShell = Nothing
			End If

		End If

		GetParentFolderName = sPath

	End Function

End Class

Class clsFolders

	Dim objFSO, objFile

	Private bVerbose

	Public Property Let verbose(bYesNo)
		bVerbose = bYesNo
	End Property

	Private Sub Class_Initialize()
		bVerbose = False
		Set objFSO = CreateObject("Scripting.FileSystemObject")
	End Sub

	Private Sub Class_Terminate()
		Set objFSO = Nothing
	End Sub

	Public Function Exists(sFolderName)
		Exists = objFSO.FolderExists(sFolderName)
	End Function

	' --------------------------------------------------
	' Create a folder recursively
	' --------------------------------------------------
	Public Function Create(ByVal sFolderName)

		Create = false

		If Not exists(sFolderName) Then

			If Create(objFSO.GetParentFolderName(sFolderName)) Then
				Create = True

				If bVerbose Then
					wScript.echo "Create folder " & sFolderName
				End If

				Call objFSO.CreateFolder(sFolderName)
			End If

		Else
			Create = True
		End If

	End Function

End Class

Class clsMSExcel

	Private oApplication
	Private sFileName
	Private bAppHasBeenStarted
	Private cFiles
	Private cFolders

	Public Property Let FileName(ByVal sName)
		sFileName = sName
	End Property

	Public Property Get FileName
		FileName = sFileName
	End Property

	Private Sub Class_Initialize()
		bAppHasBeenStarted = False
		Set oApplication = Nothing

		Set cFiles = new clsFiles
		Set cFolders = new clsFolders
	End Sub

	Private Sub Class_Terminate()
		Set oApplication = Nothing
		Set cFiles = Nothing
		Set cFolders = Nothing
	End Sub

	' --------------------------------------------------------
	' Initialize the oApplication object variable : get a pointer
	' to the current Excel.exe app if already in memory or start
	' a new instance.
	'
	' If a new instance has been started, initialize the variable
	' bAppHasBeenStarted to True so the rest of the script knows
	' that Excel should then be closed by the script.
	' --------------------------------------------------------
	Public Function Instantiate()

		If (oApplication Is Nothing) Then

			On Error Resume Next

			Set oApplication = GetObject(,"Excel.Application")

			If (Err.number <> 0) or (oApplication Is Nothing) Then
				Set oApplication = CreateObject("Excel.Application")
				' Remember that Excel has been started by
				' this script ==> should be released
				bAppHasBeenStarted = True
			End If

			Err.clear

			On Error Goto 0

		End If

		' Return True if the application was created right
		' now
		Instantiate = bAppHasBeenStarted

	End Function

	Public Sub Quit()

		On Error Resume Next
		oApplication.Quit
		On Error Goto 0

	End Sub

	' --------------------------------------------------
	' Detect if the module, class, form has code (Y/N)
	' --------------------------------------------------
	Private Function hasCodeToExport(ByVal Component)

		Dim sFirstLine

		hasCodeToExport = True

		If Component.codeModule.CountOfLines <= 2 Then
			sFirstLine = Trim(Component.codeModule.lines(1, 1))
			hasCodeToExport = Not (sFirstLine = "" Or sFirstLine = "Option Explicit")
		End If

	End Function

	' --------------------------------------------------
	' Export class, module or form to a text file on disk)
	' --------------------------------------------------
	Private Sub exportComponent(ByVal sExportPath, ByVal Component, ByVal sExtension)

		If bVerbose Then
			wScript.echo "  Export " & Component.name & sExtension
		End If

		Component.Export sExportPath & "\" & Component.name & sExtension

	End Sub

	' --------------------------------------------------
	' Export sheet to a text file on disk)
	' --------------------------------------------------
	Private Sub exportLines(ByVal sExportPath, ByVal Component)

		Dim sFileName
		Dim objFSO, outStream

		Set objFSO = CreateObject("Scripting.FileSystemObject")

		sFileName = sExportPath & "\" & Component.name & ".sheet.cls"

		If bVerbose Then
			wScript.echo "  Export " & Component.name & ".sheet.cls"
		End If

		Set outStream = objFSO.CreateTextFile(sFileName, True, False)

		outStream.Write (Component.codeModule.lines(1, Component.codeModule.CountOfLines))
		outStream.Close

		Set outStream = Nothing
		Set objFSO = Nothing

	End Sub

	' --------------------------------------------------
	' Export the ribbon and icons (if applicable)
	'
	' Use the built-in unzip feature of Windows and export
	' the "customUI" folder. That folder contains the ribbon
	' --------------------------------------------------
	Private Sub exportRibbonXML(ByVal sExportPath)

		Dim oShell, FilesInZip, file
		Dim sFolder, sScript

		' Initialization
		sFolder = sExportPath & "\Ribbon"

		wScript.echo "Prepare exportation of the ribbon"
		wScript.echo "  Export to " & sFolder

		If cFiles.exists(ZipProgram) Then

			' Fatest way - Use 7-Zip

			Set oShell = CreateObject("wScript.Shell")

			sScript = chr(34) & ZipProgram & chr(34) & " x -y " & _
				chr(34) & sFilename & chr(34) & " " & _
				"customUI -o" & chr(34) & sFolder & chr(34)
			wScript.echo "  Use 7-zip (" & sScript & ")"

			oShell.Run sScript

		Else

			' Use the Zip built-in feature of Windows
			Set oShell = CreateObject("Shell.Application")

			' Open the zip and retrieve the ribbon (if there is one)

			' oShell.NameSpace requires a .zip file (the extension is really important)
			' So add ".zip" to our file (so f.i. rename to "workbook.xlsx.zip")
			cFiles.Rename sFileName, sFileName & ".zip"

			' Now, we can get the list of files in the "zip"
			' ------------------------------------------------------------------
			' - THIS LINE IS REALLY REALLY SLOW (CAN TAKE TWO MINUTES OR MORE) -
			' ------------------------------------------------------------------
			Set FilesInZip=oShell.NameSpace(sFileName & ".zip").items

			For each file In FilesInZip

				' When file name is "customUI", we've found the folder (not the file)
				' with the manifest and icons. Export them
				If (file.Name = "customUI") Then

					' Create the target folder
					cFolders.Create(sFolder)

					' And export the ribbon (i.e. the folder called "customUI")
					' 100 = Display a progression bar
					'  10 = Overwrite if the same file is already found in sFolder
					oShell.NameSpace(sFolder).CopyHere(file), &H110

					' Ok, we can stop, we got the ribbon
					Exit For

				End if
			Next

			' Reset the original name
			cFiles.Rename sFileName & ".zip", sFileName

			Set FilesInZip = Nothing

		End if

		Set oShell = Nothing

	End Sub

	' --------------------------------------------------
	' Export the code of a workbook (can be an addin)
	' --------------------------------------------------
	Public Sub ExportVBACode()

		Dim objFSO, objShell
		Dim wb, project
		Dim bUpdateLinks, bReadOnly
		Dim sProjectFileName, sExportPath, sTemp, sFolder
		Dim vbComponent
		Dim bContinue

		Set objFSO = CreateObject("Scripting.FileSystemObject")

		If Not (objFSO.FileExists(sFileName)) Then
		 	wScript.echo "Error, the file " & sFileName & " is not found"
			Exit sub
		End If

		bUpdateLinks = False
		bReadOnly = True

		' Get the parent folder i.e. the folder where the Excel file is stored
		sFolder = cFiles.GetParentFolderName(sFileName)

		' Get the export path
		' When sFileName is f.i. c:\temp\workbook.xlsm, the export path will be
		'  		c:\temp\src\workbook.xlsm\xxxxx
		' i.e. a subfolder src will be created with a folder for the file and, in that folder
		' every objects (forms, modules, ...) and also the ribbon

		sExportPath = sFolder & "\src\" & cFiles.GetBaseName(sFileName) & "." & _
			cFiles.GetExtensionName(sFileName)

		' Make the filename absolute; add the parent folder if needed
		If (sFileName = cFiles.GetBaseName(sFileName) & "." & cFiles.GetExtensionName(sFileName)) Then
			sFileName = cFiles.GetParentFolderName(sFileName) + "\" + sFileName
		End If

		' Open Excel
		oApplication.DisplayAlerts = False
		oApplication.EnableEvents = False
		oApplication.ScreenUpdating = False

		Set wb = oApplication.Workbooks.Open(sFileName, bUpdateLinks, bReadOnly)

		Set objShell = WScript.CreateObject("WScript.Shell")

		If Not (wb is Nothing) Then

			For Each project In oApplication.VBE.VBProjects

				' In the Excel solution, we can have VBA code for the
				' itself and addins. If the VBProjects has the same name
				' that the file ==> the exportation can be done immediatetly
				' Otherwise the user will be prompted before exporting addins
				bContinue = (project.name = cFiles.GetBaseName(sFileName))

				If (project.Protection = 0) Then

					If Not (bContinue) Then
						bContinue = (objShell.Popup ("Export " & project.name & "?",,, popup_type_YesNo) = popup_answer_Yes)
					End  If

					If bContinue Then

						sTemp = "= Exporting code of " & project.name & " ="

						wScript.echo Replace(Space(Len(sTemp)), " ", "=") & vbCrLF & _
							sTemp & vbCrLf & Replace(Space(Len(sTemp)), " ", "=") & vbCrLf

						sProjectFileName = project.fileName

						If bVerbose Then
							wScript.echo "Process " & sProjectFileName
						End If

						If (sProjectFileName <> "") Then
							' Extra security : be sure the project has a name,
							' should always be the case

							wScript.echo "Export to " & sExportPath
							Call cFolders.Create(sExportPath)

							wScript.echo ""

							For Each vbComponent In project.VBComponents

								If hasCodeToExport(vbComponent) Then

									Select Case vbComponent.Type
										Case vbext_ct_ClassModule
											exportComponent sExportPath, vbComponent, ".cls"
										Case vbext_ct_StdModule
											exportComponent sExportPath, vbComponent, ".bas"
										Case vbext_ct_MSForm
											exportComponent sExportPath, vbComponent, ".frm"
									Case vbext_ct_Document
											exportLines sExportPath, vbComponent
									Case Else
										wScript.echo "Unkown vbComponent type " & vbComponent.Name
									End Select

								End If
							Next

						End If

					End If

				Else

					wScript.echo "ERROR - " & project.name & " is protected with a password, "
					wScript.echo "If you want to export code, please first start Excel, open the file, "
					wScript.echo "go to the VB editor and type your password so the code become accessible."
					wScript.echo "Without exiting Excel, start this script again."

				End if

				wScript.echo ""

			Next

		End if

		Set objShell = Nothing

		On error Resume Next

		' Fake, let Excel think the file wasn't modified
		wb.Saved = True

		' Don't save changes
		wb.Close False

		Set wb = Nothing

		On error GoTo 0

		' Restore settings
		oApplication.DisplayAlerts = True
		oApplication.EnableEvents = True
		oApplication.ScreenUpdating = True

		' And now, export the ribbon
		' Note: this is a really slow process; strange...
		Call exportRibbonXML(sExportPath)

	End Sub

End Class

Sub ShowHelp()

	wScript.echo " ============================"
	wScript.echo " = Excel Export Code script ="
	wScript.echo " ============================"
	wScript.echo ""
	wScript.echo " You need to tell which file should be processed "
	wScript.echo ""
	wScript.echo " For instance :"
	wScript.echo ""
	wScript.echo "  " & Wscript.ScriptName & " myfile.xlam"
	wScript.echo ""
	wScript.echo "	or "
	wScript.echo ""
	wScript.echo "  " & Wscript.ScriptName & " myfile.xlsm"
	wScript.echo ""
	wScript.quit

End sub

' -----------------------------------------------------
' -------------------- ENTRY POINT --------------------
' -----------------------------------------------------

Dim cMSExcel
Dim sFileName

	' Get the first argument
	If (wScript.Arguments.Count = 0) Then

		Call ShowHelp

	Else
		' Get the file name
		sFileName = Trim(Wscript.Arguments.Item(0))

		Set cMSExcel = New clsMSExcel

		Call cMSExcel.Instantiate

		cMSExcel.FileName = sFileName

		Call cMSExcel.ExportVBACode()

		' Job done, we can quit Excel
		Call cMSExcel.Quit()

		Set cMSExcel = Nothing

	End if