VBS - Export Excel Code

Source: https://github.com/cavo789/vba_excel_export_code

• Visual Basic Script: (.vbs): [excel_export_code.vbs] (https://github.com/cavo789/vba_excel_export_code/blob/master/excel_export_code.vbs):

Option Explicit

Const bVerbose = True

' Location, if installed, of 7-zip. Will make the export of the
' ribbon manifest faster
Const ZipProgram = "C:\Users\jbriggs010\scoop\shims\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

Then, use the helper CMD script to call this Visual Basic script with a single parameter/argument for the excel file to export from:

cscript excel_export_code.vbs demo.xlsm //nologo
pause

---

Appendix: Links

See Also: VBS - Import Excel Code | Excel - VBA

• Code
• Development
• Excel
• Microsoft Office
• Excel - VBA

Backlinks:

list from [[VBS - Export Excel Code]] AND -"Changelog"