From 254035322bd13087e4930edcac37c6f8896b6346 Mon Sep 17 00:00:00 2001 From: Georges Date: Sat, 11 Feb 2017 21:45:16 +0100 Subject: [PATCH 1/6] Force crlf line endings for vba sources as per #1 --- .gitattributes | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 .gitattributes diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..5c3e6ae --- /dev/null +++ b/.gitattributes @@ -0,0 +1,4 @@ +# CRLF -> LF by default, but not for modules or classes (especially classes) +* text=auto +*.bas text eol=crlf +*.cls text eol=crlf From 40dba6be941af6d1031b3df5d07cc09baebe4321 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20K=C3=BCnzli?= Date: Sun, 12 Feb 2017 02:31:12 +0100 Subject: [PATCH 2/6] modified git config to have Windows-style line endings --- src/vbaDeveloper.xlam/Build.bas | 738 +++++++++---------- src/vbaDeveloper.xlam/CustomActions.cls | 48 +- src/vbaDeveloper.xlam/ErrorHandling.bas | 40 +- src/vbaDeveloper.xlam/EventListener.cls | 140 ++-- src/vbaDeveloper.xlam/Formatter.bas | 720 +++++++++--------- src/vbaDeveloper.xlam/Menu.bas | 504 ++++++------- src/vbaDeveloper.xlam/MyCustomActions.cls | 94 +-- src/vbaDeveloper.xlam/NamedRanges.bas | 220 +++--- src/vbaDeveloper.xlam/Test.bas | 400 +++++----- src/vbaDeveloper.xlam/ThisWorkbook.sheet.cls | 58 +- src/vbaDeveloper.xlam/XMLexporter.bas | 384 +++++----- 11 files changed, 1673 insertions(+), 1673 deletions(-) diff --git a/src/vbaDeveloper.xlam/Build.bas b/src/vbaDeveloper.xlam/Build.bas index ab69abd..bb83163 100644 --- a/src/vbaDeveloper.xlam/Build.bas +++ b/src/vbaDeveloper.xlam/Build.bas @@ -1,369 +1,369 @@ -Attribute VB_Name = "Build" -''' -' Build instructions: -' 1. Open a new workbook in excel, then open the VB editor (Alt+F11) and from the menu File->Import, import this file: -' * src/vbaDeveloper.xlam/Build.bas -' 2. From tools references... add -' * Microsoft Visual Basic for Applications Extensibility 5.3 -' * Microsoft Scripting Runtime -' 3. Rename the project to 'vbaDeveloper' -' 5. Enable programatic access to VBA: -' File -> Options -> Trust Center, Trust Center Settings, -> Macros, -' tick the box: 'Enable programatic access to VBA' (In excel 2010: 'Trust access to the vba project object model') -' 6. If using a non-English version of Excel, rename your current workbook into ThisWorkbook (in VB Editor, press F4, -' then under the local name for Microsoft Excel Objects, select the workbook. Set the property '(Name)' to ThisWorkbook) -' 7. In VB Editor, press F4, then under Microsoft Excel Objects, select ThisWorkbook.Set the property 'IsAddin' to TRUE -' 8. In VB Editor, menu File-->Save Book1; Save as vbaDeveloper.xlam in the same directory as 'src' -' 9. Close excel. Open excel with a new workbook, then open the just saved vbaDeveloper.xlam -' 10.Let vbaDeveloper import its own code. Put the cursor in the function 'testImport' and press F5 -' 11.If necessary rename module 'Build1' to Build. Menu File-->Save vbaDeveloper.xlam -''' - -Option Explicit - - -Private Const IMPORT_DELAY As String = "00:00:03" - -'We need to make these variables public such that they can be given as arguments to application.ontime() -Public componentsToImport As Dictionary 'Key = componentName, Value = componentFilePath -Public sheetsToImport As Dictionary 'Key = componentName, Value = File object -Public vbaProjectToImport As VBProject - -Public Sub testImport() - Dim proj_name As String - proj_name = "VbaDeveloper" - - Dim vbaProject As Object - Set vbaProject = Application.VBE.VBProjects(proj_name) - Build.importVbaCode vbaProject -End Sub - - -Public Sub testExport() - Dim proj_name As String - proj_name = "VbaDeveloper" - - Dim vbaProject As Object - Set vbaProject = Application.VBE.VBProjects(proj_name) - Build.exportVbaCode vbaProject -End Sub - - -' Returns the directory where code is exported to or imported from. -' When createIfNotExists:=True, the directory will be created if it does not exist yet. -' This is desired when we get the directory for exporting. -' When createIfNotExists:=False and the directory does not exist, an empty String is returned. -' This is desired when we get the directory for importing. -' -' Directory names always end with a '\', unless an empty string is returned. -' Usually called with: fullWorkbookPath = wb.FullName or fullWorkbookPath = vbProject.fileName -' if the workbook is new and has never been saved, -' vbProject.fileName will throw an error while wb.FullName will return a name without slashes. -Public Function getSourceDir(fullWorkbookPath As String, createIfNotExists As Boolean) As String - ' First check if the fullWorkbookPath contains a \. - If Not InStr(fullWorkbookPath, "\") > 0 Then - 'In this case it is a new workbook, we skip it - Exit Function - End If - - Dim FSO As New Scripting.FileSystemObject - Dim projDir As String - projDir = FSO.GetParentFolderName(fullWorkbookPath) & "\" - Dim srcDir As String - srcDir = projDir & "src\" - Dim exportDir As String - exportDir = srcDir & FSO.GetFileName(fullWorkbookPath) & "\" - - If createIfNotExists Then - If Not FSO.FolderExists(srcDir) Then - FSO.CreateFolder srcDir - Debug.Print "Created Folder " & srcDir - End If - If Not FSO.FolderExists(exportDir) Then - FSO.CreateFolder exportDir - Debug.Print "Created Folder " & exportDir - End If - Else - If Not FSO.FolderExists(exportDir) Then - Debug.Print "Folder does not exist: " & exportDir - exportDir = "" - End If - End If - getSourceDir = exportDir -End Function - - -' Usually called after the given workbook is saved -Public Sub exportVbaCode(vbaProject As VBProject) - Dim vbProjectFileName As String - On Error Resume Next - 'this can throw if the workbook has never been saved. - vbProjectFileName = vbaProject.fileName - On Error GoTo 0 - If vbProjectFileName = "" Then - 'In this case it is a new workbook, we skip it - Debug.Print "No file name for project " & vbaProject.name & ", skipping" - Exit Sub - End If - - Dim export_path As String - export_path = getSourceDir(vbProjectFileName, createIfNotExists:=True) - - Debug.Print "exporting to " & export_path - 'export all components - Dim component As VBComponent - For Each component In vbaProject.VBComponents - 'lblStatus.Caption = "Exporting " & proj_name & "::" & component.Name - If hasCodeToExport(component) Then - 'Debug.Print "exporting type is " & component.Type - Select Case component.Type - Case vbext_ct_ClassModule - exportComponent export_path, component - Case vbext_ct_StdModule - exportComponent export_path, component, ".bas" - Case vbext_ct_MSForm - exportComponent export_path, component, ".frm" - Case vbext_ct_Document - exportLines export_path, component - Case Else - 'Raise "Unkown component type" - End Select - End If - Next component -End Sub - - -Private Function hasCodeToExport(component As VBComponent) As Boolean - hasCodeToExport = True - If component.codeModule.CountOfLines <= 2 Then - Dim firstLine As String - firstLine = Trim(component.codeModule.lines(1, 1)) - 'Debug.Print firstLine - hasCodeToExport = Not (firstLine = "" Or firstLine = "Option Explicit") - End If -End Function - - -'To export everything else but sheets -Private Sub exportComponent(exportPath As String, component As VBComponent, Optional extension As String = ".cls") - Debug.Print "exporting " & component.name & extension - component.Export exportPath & "\" & component.name & extension -End Sub - - -'To export sheets -Private Sub exportLines(exportPath As String, component As VBComponent) - Dim extension As String: extension = ".sheet.cls" - Dim fileName As String - fileName = exportPath & "\" & component.name & extension - Debug.Print "exporting " & component.name & extension - 'component.Export exportPath & "\" & component.name & extension - Dim FSO As New Scripting.FileSystemObject - Dim outStream As TextStream - Set outStream = FSO.CreateTextFile(fileName, True, False) - outStream.Write (component.codeModule.lines(1, component.codeModule.CountOfLines)) - outStream.Close -End Sub - - -' Usually called after the given workbook is opened. The option includeClassFiles is False by default because -' they don't import correctly from VBA. They'll have to be imported manually instead. -Public Sub importVbaCode(vbaProject As VBProject, Optional includeClassFiles As Boolean = False) - Dim vbProjectFileName As String - On Error Resume Next - 'this can throw if the workbook has never been saved. - vbProjectFileName = vbaProject.fileName - On Error GoTo 0 - If vbProjectFileName = "" Then - 'In this case it is a new workbook, we skip it - Debug.Print "No file name for project " & vbaProject.name & ", skipping" - Exit Sub - End If - - Dim export_path As String - export_path = getSourceDir(vbProjectFileName, createIfNotExists:=False) - If export_path = "" Then - 'The source directory does not exist, code has never been exported for this vbaProject. - Debug.Print "No import directory for project " & vbaProject.name & ", skipping" - Exit Sub - End If - - 'initialize globals for Application.OnTime - Set componentsToImport = New Dictionary - Set sheetsToImport = New Dictionary - Set vbaProjectToImport = vbaProject - - Dim FSO As New Scripting.FileSystemObject - Dim projContents As Folder - Set projContents = FSO.GetFolder(export_path) - Dim file As Object - For Each file In projContents.Files() - 'check if and how to import the file - checkHowToImport file, includeClassFiles - Next - - Dim componentName As String - Dim vComponentName As Variant - 'Remove all the modules and class modules - For Each vComponentName In componentsToImport.Keys - componentName = vComponentName - removeComponent vbaProject, componentName - Next - 'Then import them - Debug.Print "Invoking 'Build.importComponents'with Application.Ontime with delay " & IMPORT_DELAY - ' to prevent duplicate modules, like MyClass1 etc. - Application.OnTime Now() + TimeValue(IMPORT_DELAY), "'Build.importComponents'" - Debug.Print "almost finished importing code for " & vbaProject.name -End Sub - - -Private Sub checkHowToImport(file As Object, includeClassFiles As Boolean) - Dim fileName As String - fileName = file.name - Dim componentName As String - componentName = Left(fileName, InStr(fileName, ".") - 1) - If componentName = "Build" Then - '"don't remove or import ourself - Exit Sub - End If - - If Len(fileName) > 4 Then - Dim lastPart As String - lastPart = Right(fileName, 4) - Select Case lastPart - Case ".cls" ' 10 == Len(".sheet.cls") - If Len(fileName) > 10 And Right(fileName, 10) = ".sheet.cls" Then - 'import lines into sheet: importLines vbaProjectToImport, file - sheetsToImport.Add componentName, file - Else - ' .cls files don't import correctly because of a bug in excel, therefore we can exclude them. - ' In that case they'll have to be imported manually. - If includeClassFiles Then - 'importComponent vbaProject, file - componentsToImport.Add componentName, file.Path - End If - End If - Case ".bas", ".frm" - 'importComponent vbaProject, file - componentsToImport.Add componentName, file.Path - Case Else - 'do nothing - Debug.Print "Skipping file " & fileName - End Select - End If -End Sub - - -' Only removes the vba component if it exists -Private Sub removeComponent(vbaProject As VBProject, componentName As String) - If componentExists(vbaProject, componentName) Then - Dim c As VBComponent - Set c = vbaProject.VBComponents(componentName) - Debug.Print "removing " & c.name - vbaProject.VBComponents.Remove c - End If -End Sub - - -Public Sub importComponents() - If componentsToImport Is Nothing Then - Debug.Print "Failed to import! Dictionary 'componentsToImport' was not initialized." - Exit Sub - End If - Dim componentName As String - Dim vComponentName As Variant - For Each vComponentName In componentsToImport.Keys - componentName = vComponentName - importComponent vbaProjectToImport, componentsToImport(componentName) - Next - - 'Import the sheets - For Each vComponentName In sheetsToImport.Keys - componentName = vComponentName - importLines vbaProjectToImport, sheetsToImport(componentName) - Next - - Debug.Print "Finished importing code for " & vbaProjectToImport.name - 'We're done, clear globals explicitly to free memory. - Set componentsToImport = Nothing - Set vbaProjectToImport = Nothing -End Sub - - -' Assumes any component with same name has already been removed. -Private Sub importComponent(vbaProject As VBProject, filePath As String) - Debug.Print "Importing component from " & filePath - 'This next line is a bug! It imports all classes as modules! - vbaProject.VBComponents.Import filePath -End Sub - - -Private Sub importLines(vbaProject As VBProject, file As Object) - Dim componentName As String - componentName = Left(file.name, InStr(file.name, ".") - 1) - Dim c As VBComponent - If Not componentExists(vbaProject, componentName) Then - ' Create a sheet to import this code into. We cannot set the ws.codeName property which is read-only, - ' instead we set its vbComponent.name which leads to the same result. - Dim addedSheetCodeName As String - addedSheetCodeName = addSheetToWorkbook(componentName, vbaProject.fileName) - Set c = vbaProject.VBComponents(addedSheetCodeName) - c.name = componentName - End If - Set c = vbaProject.VBComponents(componentName) - Debug.Print "Importing lines from " & componentName & " into component " & c.name - - ' At this point compilation errors may cause a crash, so we ignore those. - On Error Resume Next - c.codeModule.DeleteLines 1, c.codeModule.CountOfLines - c.codeModule.AddFromFile file.Path - On Error GoTo 0 -End Sub - - -Public Function componentExists(ByRef proj As VBProject, name As String) As Boolean - On Error GoTo doesnt - Dim c As VBComponent - Set c = proj.VBComponents(name) - componentExists = True - Exit Function -doesnt: - componentExists = False -End Function - - -' Returns a reference to the workbook. Opens it if it is not already opened. -' Raises error if the file cannot be found. -Public Function openWorkbook(ByVal filePath As String) As Workbook - Dim wb As Workbook - Dim fileName As String - fileName = Dir(filePath) - On Error Resume Next - Set wb = Workbooks(fileName) - On Error GoTo 0 - If wb Is Nothing Then - Set wb = Workbooks.Open(filePath) 'can raise error - End If - Set openWorkbook = wb -End Function - - -' Returns the CodeName of the added sheet or an empty String if the workbook could not be opened. -Public Function addSheetToWorkbook(sheetName As String, workbookFilePath As String) As String - Dim wb As Workbook - On Error Resume Next 'can throw if given path does not exist - Set wb = openWorkbook(workbookFilePath) - On Error GoTo 0 - If Not wb Is Nothing Then - Dim ws As Worksheet - Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) - ws.name = sheetName - 'ws.CodeName = sheetName: cannot assign to read only property - Debug.Print "Sheet added " & sheetName - addSheetToWorkbook = ws.CodeName - Else - Debug.Print "Skipping file " & sheetName & ". Could not open workbook " & workbookFilePath - addSheetToWorkbook = "" - End If -End Function - +Attribute VB_Name = "Build" +''' +' Build instructions: +' 1. Open a new workbook in excel, then open the VB editor (Alt+F11) and from the menu File->Import, import this file: +' * src/vbaDeveloper.xlam/Build.bas +' 2. From tools references... add +' * Microsoft Visual Basic for Applications Extensibility 5.3 +' * Microsoft Scripting Runtime +' 3. Rename the project to 'vbaDeveloper' +' 5. Enable programatic access to VBA: +' File -> Options -> Trust Center, Trust Center Settings, -> Macros, +' tick the box: 'Enable programatic access to VBA' (In excel 2010: 'Trust access to the vba project object model') +' 6. If using a non-English version of Excel, rename your current workbook into ThisWorkbook (in VB Editor, press F4, +' then under the local name for Microsoft Excel Objects, select the workbook. Set the property '(Name)' to ThisWorkbook) +' 7. In VB Editor, press F4, then under Microsoft Excel Objects, select ThisWorkbook.Set the property 'IsAddin' to TRUE +' 8. In VB Editor, menu File-->Save Book1; Save as vbaDeveloper.xlam in the same directory as 'src' +' 9. Close excel. Open excel with a new workbook, then open the just saved vbaDeveloper.xlam +' 10.Let vbaDeveloper import its own code. Put the cursor in the function 'testImport' and press F5 +' 11.If necessary rename module 'Build1' to Build. Menu File-->Save vbaDeveloper.xlam +''' + +Option Explicit + + +Private Const IMPORT_DELAY As String = "00:00:03" + +'We need to make these variables public such that they can be given as arguments to application.ontime() +Public componentsToImport As Dictionary 'Key = componentName, Value = componentFilePath +Public sheetsToImport As Dictionary 'Key = componentName, Value = File object +Public vbaProjectToImport As VBProject + +Public Sub testImport() + Dim proj_name As String + proj_name = "VbaDeveloper" + + Dim vbaProject As Object + Set vbaProject = Application.VBE.VBProjects(proj_name) + Build.importVbaCode vbaProject +End Sub + + +Public Sub testExport() + Dim proj_name As String + proj_name = "VbaDeveloper" + + Dim vbaProject As Object + Set vbaProject = Application.VBE.VBProjects(proj_name) + Build.exportVbaCode vbaProject +End Sub + + +' Returns the directory where code is exported to or imported from. +' When createIfNotExists:=True, the directory will be created if it does not exist yet. +' This is desired when we get the directory for exporting. +' When createIfNotExists:=False and the directory does not exist, an empty String is returned. +' This is desired when we get the directory for importing. +' +' Directory names always end with a '\', unless an empty string is returned. +' Usually called with: fullWorkbookPath = wb.FullName or fullWorkbookPath = vbProject.fileName +' if the workbook is new and has never been saved, +' vbProject.fileName will throw an error while wb.FullName will return a name without slashes. +Public Function getSourceDir(fullWorkbookPath As String, createIfNotExists As Boolean) As String + ' First check if the fullWorkbookPath contains a \. + If Not InStr(fullWorkbookPath, "\") > 0 Then + 'In this case it is a new workbook, we skip it + Exit Function + End If + + Dim FSO As New Scripting.FileSystemObject + Dim projDir As String + projDir = FSO.GetParentFolderName(fullWorkbookPath) & "\" + Dim srcDir As String + srcDir = projDir & "src\" + Dim exportDir As String + exportDir = srcDir & FSO.GetFileName(fullWorkbookPath) & "\" + + If createIfNotExists Then + If Not FSO.FolderExists(srcDir) Then + FSO.CreateFolder srcDir + Debug.Print "Created Folder " & srcDir + End If + If Not FSO.FolderExists(exportDir) Then + FSO.CreateFolder exportDir + Debug.Print "Created Folder " & exportDir + End If + Else + If Not FSO.FolderExists(exportDir) Then + Debug.Print "Folder does not exist: " & exportDir + exportDir = "" + End If + End If + getSourceDir = exportDir +End Function + + +' Usually called after the given workbook is saved +Public Sub exportVbaCode(vbaProject As VBProject) + Dim vbProjectFileName As String + On Error Resume Next + 'this can throw if the workbook has never been saved. + vbProjectFileName = vbaProject.fileName + On Error GoTo 0 + If vbProjectFileName = "" Then + 'In this case it is a new workbook, we skip it + Debug.Print "No file name for project " & vbaProject.name & ", skipping" + Exit Sub + End If + + Dim export_path As String + export_path = getSourceDir(vbProjectFileName, createIfNotExists:=True) + + Debug.Print "exporting to " & export_path + 'export all components + Dim component As VBComponent + For Each component In vbaProject.VBComponents + 'lblStatus.Caption = "Exporting " & proj_name & "::" & component.Name + If hasCodeToExport(component) Then + 'Debug.Print "exporting type is " & component.Type + Select Case component.Type + Case vbext_ct_ClassModule + exportComponent export_path, component + Case vbext_ct_StdModule + exportComponent export_path, component, ".bas" + Case vbext_ct_MSForm + exportComponent export_path, component, ".frm" + Case vbext_ct_Document + exportLines export_path, component + Case Else + 'Raise "Unkown component type" + End Select + End If + Next component +End Sub + + +Private Function hasCodeToExport(component As VBComponent) As Boolean + hasCodeToExport = True + If component.codeModule.CountOfLines <= 2 Then + Dim firstLine As String + firstLine = Trim(component.codeModule.lines(1, 1)) + 'Debug.Print firstLine + hasCodeToExport = Not (firstLine = "" Or firstLine = "Option Explicit") + End If +End Function + + +'To export everything else but sheets +Private Sub exportComponent(exportPath As String, component As VBComponent, Optional extension As String = ".cls") + Debug.Print "exporting " & component.name & extension + component.Export exportPath & "\" & component.name & extension +End Sub + + +'To export sheets +Private Sub exportLines(exportPath As String, component As VBComponent) + Dim extension As String: extension = ".sheet.cls" + Dim fileName As String + fileName = exportPath & "\" & component.name & extension + Debug.Print "exporting " & component.name & extension + 'component.Export exportPath & "\" & component.name & extension + Dim FSO As New Scripting.FileSystemObject + Dim outStream As TextStream + Set outStream = FSO.CreateTextFile(fileName, True, False) + outStream.Write (component.codeModule.lines(1, component.codeModule.CountOfLines)) + outStream.Close +End Sub + + +' Usually called after the given workbook is opened. The option includeClassFiles is False by default because +' they don't import correctly from VBA. They'll have to be imported manually instead. +Public Sub importVbaCode(vbaProject As VBProject, Optional includeClassFiles As Boolean = False) + Dim vbProjectFileName As String + On Error Resume Next + 'this can throw if the workbook has never been saved. + vbProjectFileName = vbaProject.fileName + On Error GoTo 0 + If vbProjectFileName = "" Then + 'In this case it is a new workbook, we skip it + Debug.Print "No file name for project " & vbaProject.name & ", skipping" + Exit Sub + End If + + Dim export_path As String + export_path = getSourceDir(vbProjectFileName, createIfNotExists:=False) + If export_path = "" Then + 'The source directory does not exist, code has never been exported for this vbaProject. + Debug.Print "No import directory for project " & vbaProject.name & ", skipping" + Exit Sub + End If + + 'initialize globals for Application.OnTime + Set componentsToImport = New Dictionary + Set sheetsToImport = New Dictionary + Set vbaProjectToImport = vbaProject + + Dim FSO As New Scripting.FileSystemObject + Dim projContents As Folder + Set projContents = FSO.GetFolder(export_path) + Dim file As Object + For Each file In projContents.Files() + 'check if and how to import the file + checkHowToImport file, includeClassFiles + Next + + Dim componentName As String + Dim vComponentName As Variant + 'Remove all the modules and class modules + For Each vComponentName In componentsToImport.Keys + componentName = vComponentName + removeComponent vbaProject, componentName + Next + 'Then import them + Debug.Print "Invoking 'Build.importComponents'with Application.Ontime with delay " & IMPORT_DELAY + ' to prevent duplicate modules, like MyClass1 etc. + Application.OnTime Now() + TimeValue(IMPORT_DELAY), "'Build.importComponents'" + Debug.Print "almost finished importing code for " & vbaProject.name +End Sub + + +Private Sub checkHowToImport(file As Object, includeClassFiles As Boolean) + Dim fileName As String + fileName = file.name + Dim componentName As String + componentName = Left(fileName, InStr(fileName, ".") - 1) + If componentName = "Build" Then + '"don't remove or import ourself + Exit Sub + End If + + If Len(fileName) > 4 Then + Dim lastPart As String + lastPart = Right(fileName, 4) + Select Case lastPart + Case ".cls" ' 10 == Len(".sheet.cls") + If Len(fileName) > 10 And Right(fileName, 10) = ".sheet.cls" Then + 'import lines into sheet: importLines vbaProjectToImport, file + sheetsToImport.Add componentName, file + Else + ' .cls files don't import correctly because of a bug in excel, therefore we can exclude them. + ' In that case they'll have to be imported manually. + If includeClassFiles Then + 'importComponent vbaProject, file + componentsToImport.Add componentName, file.Path + End If + End If + Case ".bas", ".frm" + 'importComponent vbaProject, file + componentsToImport.Add componentName, file.Path + Case Else + 'do nothing + Debug.Print "Skipping file " & fileName + End Select + End If +End Sub + + +' Only removes the vba component if it exists +Private Sub removeComponent(vbaProject As VBProject, componentName As String) + If componentExists(vbaProject, componentName) Then + Dim c As VBComponent + Set c = vbaProject.VBComponents(componentName) + Debug.Print "removing " & c.name + vbaProject.VBComponents.Remove c + End If +End Sub + + +Public Sub importComponents() + If componentsToImport Is Nothing Then + Debug.Print "Failed to import! Dictionary 'componentsToImport' was not initialized." + Exit Sub + End If + Dim componentName As String + Dim vComponentName As Variant + For Each vComponentName In componentsToImport.Keys + componentName = vComponentName + importComponent vbaProjectToImport, componentsToImport(componentName) + Next + + 'Import the sheets + For Each vComponentName In sheetsToImport.Keys + componentName = vComponentName + importLines vbaProjectToImport, sheetsToImport(componentName) + Next + + Debug.Print "Finished importing code for " & vbaProjectToImport.name + 'We're done, clear globals explicitly to free memory. + Set componentsToImport = Nothing + Set vbaProjectToImport = Nothing +End Sub + + +' Assumes any component with same name has already been removed. +Private Sub importComponent(vbaProject As VBProject, filePath As String) + Debug.Print "Importing component from " & filePath + 'This next line is a bug! It imports all classes as modules! + vbaProject.VBComponents.Import filePath +End Sub + + +Private Sub importLines(vbaProject As VBProject, file As Object) + Dim componentName As String + componentName = Left(file.name, InStr(file.name, ".") - 1) + Dim c As VBComponent + If Not componentExists(vbaProject, componentName) Then + ' Create a sheet to import this code into. We cannot set the ws.codeName property which is read-only, + ' instead we set its vbComponent.name which leads to the same result. + Dim addedSheetCodeName As String + addedSheetCodeName = addSheetToWorkbook(componentName, vbaProject.fileName) + Set c = vbaProject.VBComponents(addedSheetCodeName) + c.name = componentName + End If + Set c = vbaProject.VBComponents(componentName) + Debug.Print "Importing lines from " & componentName & " into component " & c.name + + ' At this point compilation errors may cause a crash, so we ignore those. + On Error Resume Next + c.codeModule.DeleteLines 1, c.codeModule.CountOfLines + c.codeModule.AddFromFile file.Path + On Error GoTo 0 +End Sub + + +Public Function componentExists(ByRef proj As VBProject, name As String) As Boolean + On Error GoTo doesnt + Dim c As VBComponent + Set c = proj.VBComponents(name) + componentExists = True + Exit Function +doesnt: + componentExists = False +End Function + + +' Returns a reference to the workbook. Opens it if it is not already opened. +' Raises error if the file cannot be found. +Public Function openWorkbook(ByVal filePath As String) As Workbook + Dim wb As Workbook + Dim fileName As String + fileName = Dir(filePath) + On Error Resume Next + Set wb = Workbooks(fileName) + On Error GoTo 0 + If wb Is Nothing Then + Set wb = Workbooks.Open(filePath) 'can raise error + End If + Set openWorkbook = wb +End Function + + +' Returns the CodeName of the added sheet or an empty String if the workbook could not be opened. +Public Function addSheetToWorkbook(sheetName As String, workbookFilePath As String) As String + Dim wb As Workbook + On Error Resume Next 'can throw if given path does not exist + Set wb = openWorkbook(workbookFilePath) + On Error GoTo 0 + If Not wb Is Nothing Then + Dim ws As Worksheet + Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) + ws.name = sheetName + 'ws.CodeName = sheetName: cannot assign to read only property + Debug.Print "Sheet added " & sheetName + addSheetToWorkbook = ws.CodeName + Else + Debug.Print "Skipping file " & sheetName & ". Could not open workbook " & workbookFilePath + addSheetToWorkbook = "" + End If +End Function + diff --git a/src/vbaDeveloper.xlam/CustomActions.cls b/src/vbaDeveloper.xlam/CustomActions.cls index b69e39a..2f3f01c 100644 --- a/src/vbaDeveloper.xlam/CustomActions.cls +++ b/src/vbaDeveloper.xlam/CustomActions.cls @@ -1,24 +1,24 @@ -VERSION 1.0 CLASS -BEGIN - MultiUse = -1 'True -END -Attribute VB_Name = "CustomActions" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = False -Attribute VB_PredeclaredId = False -Attribute VB_Exposed = True -Option Explicit - -' Interface with hooks for thisWorkbook open and close actions -' -' An implementation can for example open a number of workbooks, connect to a database, load data and initialize worksheets, -' or any other tasks that otherwise have to be done manually. - -'Called after thisWorkbook is opened -Sub afterOpen() -End Sub - -'Called before thisWorkbook is closed -Sub beforeClose() -End Sub - +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CustomActions" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = True +Option Explicit + +' Interface with hooks for thisWorkbook open and close actions +' +' An implementation can for example open a number of workbooks, connect to a database, load data and initialize worksheets, +' or any other tasks that otherwise have to be done manually. + +'Called after thisWorkbook is opened +Sub afterOpen() +End Sub + +'Called before thisWorkbook is closed +Sub beforeClose() +End Sub + diff --git a/src/vbaDeveloper.xlam/ErrorHandling.bas b/src/vbaDeveloper.xlam/ErrorHandling.bas index 4f2250e..e7122f5 100644 --- a/src/vbaDeveloper.xlam/ErrorHandling.bas +++ b/src/vbaDeveloper.xlam/ErrorHandling.bas @@ -1,20 +1,20 @@ -Attribute VB_Name = "ErrorHandling" -Option Explicit - -Public Sub RaiseError(errNumber As Integer, Optional errSource As String = "", Optional errDescription As String = "") - If errSource = "" Then - 'set default values - errSource = Err.Source - errDescription = Err.Description - End If - Err.Raise vbObjectError + errNumber, errSource, errDescription -End Sub - - -Public Sub handleError(Optional errLocation As String = "") - Dim errorMessage As String - errorMessage = "Error in " & errLocation & ", [" & Err.Source & "] : error number " & Err.Number & vbNewLine & Err.Description - Debug.Print errorMessage - MsgBox errorMessage, vbCritical, "vbaDeveloper ErrorHandler" -End Sub - +Attribute VB_Name = "ErrorHandling" +Option Explicit + +Public Sub RaiseError(errNumber As Integer, Optional errSource As String = "", Optional errDescription As String = "") + If errSource = "" Then + 'set default values + errSource = Err.Source + errDescription = Err.Description + End If + Err.Raise vbObjectError + errNumber, errSource, errDescription +End Sub + + +Public Sub handleError(Optional errLocation As String = "") + Dim errorMessage As String + errorMessage = "Error in " & errLocation & ", [" & Err.Source & "] : error number " & Err.Number & vbNewLine & Err.Description + Debug.Print errorMessage + MsgBox errorMessage, vbCritical, "vbaDeveloper ErrorHandler" +End Sub + diff --git a/src/vbaDeveloper.xlam/EventListener.cls b/src/vbaDeveloper.xlam/EventListener.cls index 885a0ae..719b269 100644 --- a/src/vbaDeveloper.xlam/EventListener.cls +++ b/src/vbaDeveloper.xlam/EventListener.cls @@ -1,70 +1,70 @@ -VERSION 1.0 CLASS -BEGIN - MultiUse = -1 'True -END -Attribute VB_Name = "EventListener" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = False -Attribute VB_PredeclaredId = False -Attribute VB_Exposed = False -Option Explicit - -'This class receives and acts upon events from the excel application. -' To disable this eventhandling, simply don't instantiate this class. See Thisworkbook. - - -Private WithEvents App As Application -Attribute App.VB_VarHelpID = -1 - - -Private Sub Class_Initialize() - Set App = Application -End Sub - - -Private Sub App_WorkbookAfterSave(ByVal wb As Workbook, ByVal success As Boolean) - On Error GoTo App_WorkbookAfterSave_Error - - 'Export all the modules for this work book if save was successful - If success Then - Build.exportVbaCode wb.VBProject - NamedRanges.exportNamedRanges wb - MsgBox "Finished saving workbook: " & wb.name & " . Code is exported." - Else - MsgBox "Saving workbook: " & wb.name & " was not successful. Code is not exported." - End If - - Exit Sub -App_WorkbookAfterSave_Error: - ErrorHandling.handleError "vbaDeveloper.EventListener afterSave" -End Sub - - -Private Sub App_WorkbookBeforeSave(ByVal wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean) - If Not Cancel Then - Formatter.formatProject wb.VBProject - End If -End Sub - - -Private Sub App_WorkbookOpen(ByVal wb As Workbook) - On Error GoTo App_WorkbookOpen_Error - - 'Import all the modules for this workbook - Dim importNow As Integer - importNow = MsgBox("Import the code for " & wb.name & " now?", vbYesNo, "EventListener Workbook open event") - If importNow = vbYes Then - Build.importVbaCode wb.VBProject - NamedRanges.importNamedRanges wb - End If - - Exit Sub -App_WorkbookOpen_Error: - ErrorHandling.handleError "vbaDeveloper.EventListener WorkbookOpen" -End Sub - - -Private Sub Class_Terminate() - Set App = Nothing -End Sub - +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "EventListener" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +'This class receives and acts upon events from the excel application. +' To disable this eventhandling, simply don't instantiate this class. See Thisworkbook. + + +Private WithEvents App As Application +Attribute App.VB_VarHelpID = -1 + + +Private Sub Class_Initialize() + Set App = Application +End Sub + + +Private Sub App_WorkbookAfterSave(ByVal wb As Workbook, ByVal success As Boolean) + On Error GoTo App_WorkbookAfterSave_Error + + 'Export all the modules for this work book if save was successful + If success Then + Build.exportVbaCode wb.VBProject + NamedRanges.exportNamedRanges wb + MsgBox "Finished saving workbook: " & wb.name & " . Code is exported." + Else + MsgBox "Saving workbook: " & wb.name & " was not successful. Code is not exported." + End If + + Exit Sub +App_WorkbookAfterSave_Error: + ErrorHandling.handleError "vbaDeveloper.EventListener afterSave" +End Sub + + +Private Sub App_WorkbookBeforeSave(ByVal wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean) + If Not Cancel Then + Formatter.formatProject wb.VBProject + End If +End Sub + + +Private Sub App_WorkbookOpen(ByVal wb As Workbook) + On Error GoTo App_WorkbookOpen_Error + + 'Import all the modules for this workbook + Dim importNow As Integer + importNow = MsgBox("Import the code for " & wb.name & " now?", vbYesNo, "EventListener Workbook open event") + If importNow = vbYes Then + Build.importVbaCode wb.VBProject + NamedRanges.importNamedRanges wb + End If + + Exit Sub +App_WorkbookOpen_Error: + ErrorHandling.handleError "vbaDeveloper.EventListener WorkbookOpen" +End Sub + + +Private Sub Class_Terminate() + Set App = Nothing +End Sub + diff --git a/src/vbaDeveloper.xlam/Formatter.bas b/src/vbaDeveloper.xlam/Formatter.bas index fa74e01..5f9eb6c 100644 --- a/src/vbaDeveloper.xlam/Formatter.bas +++ b/src/vbaDeveloper.xlam/Formatter.bas @@ -1,360 +1,360 @@ -Attribute VB_Name = "Formatter" -Option Explicit - -Private Const BEG_SUB = "Sub " -Private Const END_SUB = "End Sub" -Private Const BEG_PB_SUB = "Public Sub " -Private Const BEG_PV_SUB = "Private Sub " -Private Const BEG_FR_SUB = "Friend Sub " -Private Const BEG_PB_ST_SUB = "Public Static Sub " -Private Const BEG_PV_ST_SUB = "Private Static Sub " -Private Const BEG_FR_ST_SUB = "Friend Static Sub " - -Private Const BEG_FUN = "Function " -Private Const END_FUN = "End Function" -Private Const BEG_PB_FUN = "Public Function " -Private Const BEG_PV_FUN = "Private Function " -Private Const BEG_FR_FUN = "Friend Function " -Private Const BEG_PB_ST_FUN = "Public Static Function " -Private Const BEG_PV_ST_FUN = "Private Static Function " -Private Const BEG_FR_ST_FUN = "Friend Static Function " - -Private Const BEG_PROP = "Property " -Private Const END_PROP = "End Property" -Private Const BEG_PB_PROP = "Public Property " -Private Const BEG_PV_PROP = "Private Property " -Private Const BEG_FR_PROP = "Friend Property " -Private Const BEG_PB_ST_PROP = "Public Static Property " -Private Const BEG_PV_ST_PROP = "Private Static Property " -Private Const BEG_FR_ST_PROP = "Friend Static Property " - -Private Const BEG_ENUM = "Enum " -Private Const END_ENUM = "End Enum" -Private Const BEG_PB_ENUM = "Public Enum " -Private Const BEG_PV_ENUM = "Private Enum " - -Private Const BEG_IF = "If " -Private Const END_IF = "End If" -Private Const BEG_WITH = "With " -Private Const END_WITH = "End With" - -Private Const BEG_SELECT = "Select " -Private Const END_SELECT = "End Select" - -Private Const BEG_FOR = "For " -Private Const END_FOR = "Next " -Private Const BEG_DOWHILE = "Do While " -Private Const BEG_DOUNTIL = "Do Until " -Private Const BEG_WHILE = "While " -Private Const END_WHILE = "Wend" - -Private Const BEG_TYPE = "Type " -Private Const END_TYPE = "End Type" -Private Const BEG_PB_TYPE = "Public Type " -Private Const BEG_PV_TYPE = "Private Type " - -' Single words that need to be handled separately -Private Const ONEWORD_END_FOR = "Next" -Private Const ONEWORD_DO = "Do" -Private Const ONEWORD_END_LOOP = "Loop" -Private Const ONEWORD_ELSE = "Else" -Private Const BEG_END_ELSEIF = "ElseIf" -Private Const BEG_END_CASE = "Case " - -Private Const THEN_KEYWORD = "Then" -Private Const LINE_CONTINUATION = "_" - -Private Const INDENT = " " - -Private words As Dictionary 'Keys are Strings, Value is an Integer indicating change in indentation -Private indentation(0 To 20) As Variant ' Prevent repeatedly building the same strings by looking them up in here - -' 3-state data type for checking if part of code is within a string or not -Private Enum StringStatus - InString - MaybeInString - NotInString -End Enum - -Private Sub initialize() - initializeWords - initializeIndentation -End Sub - -Private Sub initializeIndentation() - Dim indentString As String - indentString = "" - Dim i As Integer - For i = 0 To UBound(indentation) - indentation(i) = indentString - indentString = indentString & INDENT - Next -End Sub - -Private Sub initializeWords() - Dim w As Dictionary - Set w = New Dictionary - - w.Add BEG_SUB, 1 - w.Add END_SUB, -1 - w.Add BEG_PB_SUB, 1 - w.Add BEG_PV_SUB, 1 - w.Add BEG_FR_SUB, 1 - w.Add BEG_PB_ST_SUB, 1 - w.Add BEG_PV_ST_SUB, 1 - w.Add BEG_FR_ST_SUB, 1 - - w.Add BEG_FUN, 1 - w.Add END_FUN, -1 - w.Add BEG_PB_FUN, 1 - w.Add BEG_PV_FUN, 1 - w.Add BEG_FR_FUN, 1 - w.Add BEG_PB_ST_FUN, 1 - w.Add BEG_PV_ST_FUN, 1 - w.Add BEG_FR_ST_FUN, 1 - - w.Add BEG_PROP, 1 - w.Add END_PROP, -1 - w.Add BEG_PB_PROP, 1 - w.Add BEG_PV_PROP, 1 - w.Add BEG_FR_PROP, 1 - w.Add BEG_PB_ST_PROP, 1 - w.Add BEG_PV_ST_PROP, 1 - w.Add BEG_FR_ST_PROP, 1 - - w.Add BEG_ENUM, 1 - w.Add END_ENUM, -1 - w.Add BEG_PB_ENUM, 1 - w.Add BEG_PV_ENUM, 1 - - w.Add BEG_IF, 1 - w.Add END_IF, -1 - 'because any following 'Case' indents to the left we jump two - w.Add BEG_SELECT, 2 - w.Add END_SELECT, -2 - w.Add BEG_WITH, 1 - w.Add END_WITH, -1 - - w.Add BEG_FOR, 1 - w.Add END_FOR, -1 - w.Add BEG_DOWHILE, 1 - w.Add BEG_DOUNTIL, 1 - w.Add BEG_WHILE, 1 - w.Add END_WHILE, -1 - - w.Add BEG_TYPE, 1 - w.Add END_TYPE, -1 - w.Add BEG_PB_TYPE, 1 - w.Add BEG_PV_TYPE, 1 - - Set words = w -End Sub - - -Private Property Get vbaWords() As Dictionary - If words Is Nothing Then - initialize - End If - Set vbaWords = words -End Property - -Public Sub testFormatting() - If words Is Nothing Then - initialize - End If - 'Debug.Print Application.VBE.ActiveCodePane.codePane.Parent.Name - 'Debug.Print Application.VBE.ActiveWindow.caption - - Dim projName As String, moduleName As String - projName = "vbaDeveloper" - moduleName = "Test" - Dim vbaProject As VBProject - Set vbaProject = Application.VBE.VBProjects(projName) - Dim code As codeModule - Set code = vbaProject.VBComponents(moduleName).codeModule - - 'removeIndentation code - 'formatCode code - formatProject vbaProject -End Sub - -Public Sub formatProject(vbaProject As VBProject) - Dim codePane As codeModule - - Dim component As Variant - For Each component In vbaProject.VBComponents - Set codePane = component.codeModule - Debug.Print "Formatting " & component.name - formatCode codePane - Next -End Sub - -Public Sub format() - formatCode Application.VBE.ActiveCodePane.codeModule -End Sub - - -Public Sub formatCode(codePane As codeModule) - On Error GoTo formatCodeError - Dim lineCount As Integer - lineCount = codePane.CountOfLines - - Dim indentLevel As Integer, nextLevel As Integer, levelChange As Integer - indentLevel = 0 - Dim lineNr As Integer - For lineNr = 1 To lineCount - Dim line As String - line = Trim(codePane.lines(lineNr, 1)) - If Not line = "" Then - If isEqual(ONEWORD_ELSE, line) _ - Or lineStartsWith(BEG_END_ELSEIF, line) _ - Or lineStartsWith(BEG_END_CASE, line) Then - ' Case, Else, ElseIf need to jump to the left - levelChange = 1 - indentLevel = -1 + indentLevel - ElseIf isLabel(line) Then - ' Labels don't have indentation - levelChange = indentLevel - indentLevel = 0 - ' check for oneline If statemts - ElseIf isOneLineIfStatemt(line) Then - levelChange = 0 - Else - levelChange = indentChange(line) - End If - - nextLevel = indentLevel + levelChange - If levelChange <= -1 Then - indentLevel = nextLevel - End If - - line = indentation(indentLevel) + line - indentLevel = nextLevel - End If - Call codePane.ReplaceLine(lineNr, line) - Next - Exit Sub -formatCodeError: - Debug.Print "Error while formatting " & codePane.Parent.name - Debug.Print Err.Number & " " & Err.Description - Debug.Print " on line " & lineNr & ": " & line - Debug.Print "indentLevel: " & indentLevel & " , levelChange: " & levelChange -End Sub - - -Public Sub removeIndentation(codePane As codeModule) - Dim lineCount As Integer - lineCount = codePane.CountOfLines - - Dim lineNr As Integer - For lineNr = 1 To lineCount - Dim line As String - line = codePane.lines(lineNr, 1) - line = Trim(line) - Call codePane.ReplaceLine(lineNr, line) - Next -End Sub - -Private Function indentChange(ByVal line As String) As Integer - indentChange = 0 - Dim w As Dictionary - Set w = vbaWords - - If isEqual(line, ONEWORD_END_FOR) Or _ - isEqual(line, ONEWORD_END_LOOP) Then - indentChange = -1 - GoTo hell - End If - If isEqual(ONEWORD_DO, line) Then - indentChange = 1 - GoTo hell - End If - Dim word As String - Dim vord As Variant - For Each vord In w.Keys - word = vord 'Cast the Variant to a String - If lineStartsWith(word, line) Then - indentChange = vbaWords(word) - GoTo hell - End If - Next -hell: -End Function - -' Returns true if both strings are equal, ignoring case -Private Function isEqual(first As String, second As String) As Boolean - isEqual = (StrComp(first, second, vbTextCompare) = 0) -End Function - -' Returns True if strToCheck begins with begin, ignoring case -Private Function lineStartsWith(begin As String, strToCheck As String) As Boolean - lineStartsWith = False - Dim beginLength As Integer - beginLength = Len(begin) - If Len(strToCheck) >= beginLength Then - lineStartsWith = isEqual(begin, Left(strToCheck, beginLength)) - End If -End Function - - -' Returns True if strToCheck ends with ending, ignoring case -Private Function lineEndsWith(ending As String, strToCheck As String) As Boolean - lineEndsWith = False - Dim length As Integer - length = Len(ending) - If Len(strToCheck) >= length Then - lineEndsWith = isEqual(ending, Right(strToCheck, length)) - End If -End Function - - -Private Function isLabel(line As String) As Boolean - 'it must end with a colon: and may not contain a space. - isLabel = (Right(line, 1) = ":") And (InStr(line, " ") < 1) -End Function - - -Private Function isOneLineIfStatemt(line As String) As Boolean - Dim trimmedLine As String - trimmedLine = TrimComments(line) - isOneLineIfStatemt = (lineStartsWith(BEG_IF, trimmedLine) And (Not lineEndsWith(THEN_KEYWORD, trimmedLine)) And Not lineEndsWith(LINE_CONTINUATION, trimmedLine)) -End Function - - -' Trims trailing comments (and whitespace before a comment) from a line of code -Private Function TrimComments(ByVal line As String) As String - Dim c As Long - Dim inQuotes As StringStatus - Dim inComment As Boolean - - inQuotes = NotInString - inComment = False - For c = 1 To Len(line) - If Mid(line, c, 1) = Chr(34) Then - ' Found a double quote - Select Case inQuotes - Case NotInString: - inQuotes = InString - Case InString: - inQuotes = MaybeInString - Case MaybeInString: - inQuotes = InString - End Select - Else - ' Resolve uncertain string status - If inQuotes = MaybeInString Then - inQuotes = NotInString - End If - End If - ' Now know as much about status inside double quotes as possible, can test for comment - If inQuotes = NotInString And Mid(line, c, 1) = "'" Then - inComment = True - Exit For - End If - Next c - If inComment Then - TrimComments = Trim(Left(line, c - 1)) - Else - TrimComments = line - End If -End Function +Attribute VB_Name = "Formatter" +Option Explicit + +Private Const BEG_SUB = "Sub " +Private Const END_SUB = "End Sub" +Private Const BEG_PB_SUB = "Public Sub " +Private Const BEG_PV_SUB = "Private Sub " +Private Const BEG_FR_SUB = "Friend Sub " +Private Const BEG_PB_ST_SUB = "Public Static Sub " +Private Const BEG_PV_ST_SUB = "Private Static Sub " +Private Const BEG_FR_ST_SUB = "Friend Static Sub " + +Private Const BEG_FUN = "Function " +Private Const END_FUN = "End Function" +Private Const BEG_PB_FUN = "Public Function " +Private Const BEG_PV_FUN = "Private Function " +Private Const BEG_FR_FUN = "Friend Function " +Private Const BEG_PB_ST_FUN = "Public Static Function " +Private Const BEG_PV_ST_FUN = "Private Static Function " +Private Const BEG_FR_ST_FUN = "Friend Static Function " + +Private Const BEG_PROP = "Property " +Private Const END_PROP = "End Property" +Private Const BEG_PB_PROP = "Public Property " +Private Const BEG_PV_PROP = "Private Property " +Private Const BEG_FR_PROP = "Friend Property " +Private Const BEG_PB_ST_PROP = "Public Static Property " +Private Const BEG_PV_ST_PROP = "Private Static Property " +Private Const BEG_FR_ST_PROP = "Friend Static Property " + +Private Const BEG_ENUM = "Enum " +Private Const END_ENUM = "End Enum" +Private Const BEG_PB_ENUM = "Public Enum " +Private Const BEG_PV_ENUM = "Private Enum " + +Private Const BEG_IF = "If " +Private Const END_IF = "End If" +Private Const BEG_WITH = "With " +Private Const END_WITH = "End With" + +Private Const BEG_SELECT = "Select " +Private Const END_SELECT = "End Select" + +Private Const BEG_FOR = "For " +Private Const END_FOR = "Next " +Private Const BEG_DOWHILE = "Do While " +Private Const BEG_DOUNTIL = "Do Until " +Private Const BEG_WHILE = "While " +Private Const END_WHILE = "Wend" + +Private Const BEG_TYPE = "Type " +Private Const END_TYPE = "End Type" +Private Const BEG_PB_TYPE = "Public Type " +Private Const BEG_PV_TYPE = "Private Type " + +' Single words that need to be handled separately +Private Const ONEWORD_END_FOR = "Next" +Private Const ONEWORD_DO = "Do" +Private Const ONEWORD_END_LOOP = "Loop" +Private Const ONEWORD_ELSE = "Else" +Private Const BEG_END_ELSEIF = "ElseIf" +Private Const BEG_END_CASE = "Case " + +Private Const THEN_KEYWORD = "Then" +Private Const LINE_CONTINUATION = "_" + +Private Const INDENT = " " + +Private words As Dictionary 'Keys are Strings, Value is an Integer indicating change in indentation +Private indentation(0 To 20) As Variant ' Prevent repeatedly building the same strings by looking them up in here + +' 3-state data type for checking if part of code is within a string or not +Private Enum StringStatus + InString + MaybeInString + NotInString +End Enum + +Private Sub initialize() + initializeWords + initializeIndentation +End Sub + +Private Sub initializeIndentation() + Dim indentString As String + indentString = "" + Dim i As Integer + For i = 0 To UBound(indentation) + indentation(i) = indentString + indentString = indentString & INDENT + Next +End Sub + +Private Sub initializeWords() + Dim w As Dictionary + Set w = New Dictionary + + w.Add BEG_SUB, 1 + w.Add END_SUB, -1 + w.Add BEG_PB_SUB, 1 + w.Add BEG_PV_SUB, 1 + w.Add BEG_FR_SUB, 1 + w.Add BEG_PB_ST_SUB, 1 + w.Add BEG_PV_ST_SUB, 1 + w.Add BEG_FR_ST_SUB, 1 + + w.Add BEG_FUN, 1 + w.Add END_FUN, -1 + w.Add BEG_PB_FUN, 1 + w.Add BEG_PV_FUN, 1 + w.Add BEG_FR_FUN, 1 + w.Add BEG_PB_ST_FUN, 1 + w.Add BEG_PV_ST_FUN, 1 + w.Add BEG_FR_ST_FUN, 1 + + w.Add BEG_PROP, 1 + w.Add END_PROP, -1 + w.Add BEG_PB_PROP, 1 + w.Add BEG_PV_PROP, 1 + w.Add BEG_FR_PROP, 1 + w.Add BEG_PB_ST_PROP, 1 + w.Add BEG_PV_ST_PROP, 1 + w.Add BEG_FR_ST_PROP, 1 + + w.Add BEG_ENUM, 1 + w.Add END_ENUM, -1 + w.Add BEG_PB_ENUM, 1 + w.Add BEG_PV_ENUM, 1 + + w.Add BEG_IF, 1 + w.Add END_IF, -1 + 'because any following 'Case' indents to the left we jump two + w.Add BEG_SELECT, 2 + w.Add END_SELECT, -2 + w.Add BEG_WITH, 1 + w.Add END_WITH, -1 + + w.Add BEG_FOR, 1 + w.Add END_FOR, -1 + w.Add BEG_DOWHILE, 1 + w.Add BEG_DOUNTIL, 1 + w.Add BEG_WHILE, 1 + w.Add END_WHILE, -1 + + w.Add BEG_TYPE, 1 + w.Add END_TYPE, -1 + w.Add BEG_PB_TYPE, 1 + w.Add BEG_PV_TYPE, 1 + + Set words = w +End Sub + + +Private Property Get vbaWords() As Dictionary + If words Is Nothing Then + initialize + End If + Set vbaWords = words +End Property + +Public Sub testFormatting() + If words Is Nothing Then + initialize + End If + 'Debug.Print Application.VBE.ActiveCodePane.codePane.Parent.Name + 'Debug.Print Application.VBE.ActiveWindow.caption + + Dim projName As String, moduleName As String + projName = "vbaDeveloper" + moduleName = "Test" + Dim vbaProject As VBProject + Set vbaProject = Application.VBE.VBProjects(projName) + Dim code As codeModule + Set code = vbaProject.VBComponents(moduleName).codeModule + + 'removeIndentation code + 'formatCode code + formatProject vbaProject +End Sub + +Public Sub formatProject(vbaProject As VBProject) + Dim codePane As codeModule + + Dim component As Variant + For Each component In vbaProject.VBComponents + Set codePane = component.codeModule + Debug.Print "Formatting " & component.name + formatCode codePane + Next +End Sub + +Public Sub format() + formatCode Application.VBE.ActiveCodePane.codeModule +End Sub + + +Public Sub formatCode(codePane As codeModule) + On Error GoTo formatCodeError + Dim lineCount As Integer + lineCount = codePane.CountOfLines + + Dim indentLevel As Integer, nextLevel As Integer, levelChange As Integer + indentLevel = 0 + Dim lineNr As Integer + For lineNr = 1 To lineCount + Dim line As String + line = Trim(codePane.lines(lineNr, 1)) + If Not line = "" Then + If isEqual(ONEWORD_ELSE, line) _ + Or lineStartsWith(BEG_END_ELSEIF, line) _ + Or lineStartsWith(BEG_END_CASE, line) Then + ' Case, Else, ElseIf need to jump to the left + levelChange = 1 + indentLevel = -1 + indentLevel + ElseIf isLabel(line) Then + ' Labels don't have indentation + levelChange = indentLevel + indentLevel = 0 + ' check for oneline If statemts + ElseIf isOneLineIfStatemt(line) Then + levelChange = 0 + Else + levelChange = indentChange(line) + End If + + nextLevel = indentLevel + levelChange + If levelChange <= -1 Then + indentLevel = nextLevel + End If + + line = indentation(indentLevel) + line + indentLevel = nextLevel + End If + Call codePane.ReplaceLine(lineNr, line) + Next + Exit Sub +formatCodeError: + Debug.Print "Error while formatting " & codePane.Parent.name + Debug.Print Err.Number & " " & Err.Description + Debug.Print " on line " & lineNr & ": " & line + Debug.Print "indentLevel: " & indentLevel & " , levelChange: " & levelChange +End Sub + + +Public Sub removeIndentation(codePane As codeModule) + Dim lineCount As Integer + lineCount = codePane.CountOfLines + + Dim lineNr As Integer + For lineNr = 1 To lineCount + Dim line As String + line = codePane.lines(lineNr, 1) + line = Trim(line) + Call codePane.ReplaceLine(lineNr, line) + Next +End Sub + +Private Function indentChange(ByVal line As String) As Integer + indentChange = 0 + Dim w As Dictionary + Set w = vbaWords + + If isEqual(line, ONEWORD_END_FOR) Or _ + isEqual(line, ONEWORD_END_LOOP) Then + indentChange = -1 + GoTo hell + End If + If isEqual(ONEWORD_DO, line) Then + indentChange = 1 + GoTo hell + End If + Dim word As String + Dim vord As Variant + For Each vord In w.Keys + word = vord 'Cast the Variant to a String + If lineStartsWith(word, line) Then + indentChange = vbaWords(word) + GoTo hell + End If + Next +hell: +End Function + +' Returns true if both strings are equal, ignoring case +Private Function isEqual(first As String, second As String) As Boolean + isEqual = (StrComp(first, second, vbTextCompare) = 0) +End Function + +' Returns True if strToCheck begins with begin, ignoring case +Private Function lineStartsWith(begin As String, strToCheck As String) As Boolean + lineStartsWith = False + Dim beginLength As Integer + beginLength = Len(begin) + If Len(strToCheck) >= beginLength Then + lineStartsWith = isEqual(begin, Left(strToCheck, beginLength)) + End If +End Function + + +' Returns True if strToCheck ends with ending, ignoring case +Private Function lineEndsWith(ending As String, strToCheck As String) As Boolean + lineEndsWith = False + Dim length As Integer + length = Len(ending) + If Len(strToCheck) >= length Then + lineEndsWith = isEqual(ending, Right(strToCheck, length)) + End If +End Function + + +Private Function isLabel(line As String) As Boolean + 'it must end with a colon: and may not contain a space. + isLabel = (Right(line, 1) = ":") And (InStr(line, " ") < 1) +End Function + + +Private Function isOneLineIfStatemt(line As String) As Boolean + Dim trimmedLine As String + trimmedLine = TrimComments(line) + isOneLineIfStatemt = (lineStartsWith(BEG_IF, trimmedLine) And (Not lineEndsWith(THEN_KEYWORD, trimmedLine)) And Not lineEndsWith(LINE_CONTINUATION, trimmedLine)) +End Function + + +' Trims trailing comments (and whitespace before a comment) from a line of code +Private Function TrimComments(ByVal line As String) As String + Dim c As Long + Dim inQuotes As StringStatus + Dim inComment As Boolean + + inQuotes = NotInString + inComment = False + For c = 1 To Len(line) + If Mid(line, c, 1) = Chr(34) Then + ' Found a double quote + Select Case inQuotes + Case NotInString: + inQuotes = InString + Case InString: + inQuotes = MaybeInString + Case MaybeInString: + inQuotes = InString + End Select + Else + ' Resolve uncertain string status + If inQuotes = MaybeInString Then + inQuotes = NotInString + End If + End If + ' Now know as much about status inside double quotes as possible, can test for comment + If inQuotes = NotInString And Mid(line, c, 1) = "'" Then + inComment = True + Exit For + End If + Next c + If inComment Then + TrimComments = Trim(Left(line, c - 1)) + Else + TrimComments = line + End If +End Function diff --git a/src/vbaDeveloper.xlam/Menu.bas b/src/vbaDeveloper.xlam/Menu.bas index d1070a4..a0ccff5 100644 --- a/src/vbaDeveloper.xlam/Menu.bas +++ b/src/vbaDeveloper.xlam/Menu.bas @@ -1,252 +1,252 @@ -Attribute VB_Name = "Menu" -Option Explicit - -Private Const MENU_TITLE = "VbaDeveloper" -Private Const XML_MENU_TITLE = "XML Import-Export" -Private Const MENU_REFRESH = "Refresh this menu" - - -Public Sub createMenu() - Dim rootMenu As CommandBarPopup - - 'Add the top-level menu to the ribbon Add-ins section - Set rootMenu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _ - Before:=10, _ - Temporary:=True) - rootMenu.caption = MENU_TITLE - - Dim exSubMenu As CommandBarPopup - Dim imSubMenu As CommandBarPopup - Dim formatSubMenu As CommandBarPopup - Set exSubMenu = addSubmenu(rootMenu, 1, "Export code for ...") - Set imSubMenu = addSubmenu(rootMenu, 2, "Import code for ...") - Set formatSubMenu = addSubmenu(rootMenu, 3, "Format code for ...") - addMenuSeparator rootMenu - Dim refreshItem As CommandBarButton - Set refreshItem = addMenuItem(rootMenu, "Menu.refreshMenu", MENU_REFRESH) - refreshItem.FaceId = 37 - - ' menuItem.FaceId = FaceId ' set a picture - Dim vProject As Variant - For Each vProject In Application.VBE.VBProjects - ' We skip over unsaved projects where project.fileName throws error - On Error GoTo nextProject - Dim project As VBProject - Set project = vProject - Dim projectName As String, caption As String - - projectName = project.name - caption = projectName & " (" & Dir(project.fileName) & ")" '<- this can throw error - - Dim exCommand As String, imCommand As String, formatCommand As String - exCommand = "'Menu.exportVbProject """ & projectName & """'" - imCommand = "'Menu.importVbProject """ & projectName & """'" - formatCommand = "'Menu.formatVbProject """ & projectName & """'" - - addMenuItem exSubMenu, exCommand, caption - addMenuItem imSubMenu, imCommand, caption - addMenuItem formatSubMenu, formatCommand, caption -nextProject: - Next vProject - On Error GoTo 0 'reset the error handling - - 'Add menu items for creating and rebuilding XML files - Dim xmlMenu As CommandBarPopup, exXmlSubMenu As CommandBarPopup - Set xmlMenu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _ - Before:=10, _ - Temporary:=True) - xmlMenu.caption = XML_MENU_TITLE - - Set exXmlSubMenu = addSubmenu(xmlMenu, 1, "Export XML for ...") - Dim rebuildButton As CommandBarButton - Set rebuildButton = addMenuItem(xmlMenu, "Menu.rebuildXML", "Rebuild a file") - rebuildButton.FaceId = 35 - Set refreshItem = addMenuItem(xmlMenu, "Menu.refreshMenu", MENU_REFRESH) - refreshItem.FaceId = 37 - - 'add menu items for all open files - Dim fileName As String - Dim openFile As Workbook - For Each openFile In Application.Workbooks - fileName = openFile.name - Call addMenuItem(exXmlSubMenu, "'Menu.exportXML """ & fileName & """'", fileName) - Next openFile - -End Sub - - -Private Function addMenuItem(menu As CommandBarPopup, ByVal onAction As String, ByVal caption As String) As CommandBarButton - Dim menuItem As CommandBarButton - Set menuItem = menu.Controls.Add(Type:=msoControlButton) - menuItem.onAction = onAction - menuItem.caption = caption - Set addMenuItem = menuItem -End Function - - -Private Function addSubmenu(menu As CommandBarPopup, ByVal position As Integer, ByVal caption As String) As CommandBarPopup - Dim subMenu As CommandBarPopup - Set subMenu = menu.Controls.Add(Type:=msoControlPopup) - subMenu.onAction = position - subMenu.caption = caption - Set addSubmenu = subMenu -End Function - - -Private Sub addMenuSeparator(menuItem As CommandBarPopup) - menuItem.BeginGroup = True -End Sub - - -'This sub should be executed when the workbook is closed -Public Sub deleteMenu() - 'For each control, check if its name matches the names of our custom menus - using this method deletes multiple instances of the menu in case duplicates are mistakenly created. - Dim cbControl - On Error Resume Next - For Each cbControl In CommandBars(1).Controls 'TODO if more menus are added, should use a collection instead of multiple if statements (keep code DRY) - If cbControl.caption = MENU_TITLE Then - Debug.Print "Deleting" & MENU_TITLE - cbControl.Delete - End If - If cbControl.caption = XML_MENU_TITLE Then - Debug.Print "Deleting" & XML_MENU_TITLE - cbControl.Delete - End If - Next cbControl - On Error GoTo 0 -End Sub - -Public Sub refreshMenu() - menu.deleteMenu - menu.createMenu -End Sub - -Public Sub exportVbProject(ByVal projectName As String) - On Error GoTo exportVbProject_Error - - Dim project As VBProject - Set project = Application.VBE.VBProjects(projectName) - Build.exportVbaCode project - Dim wb As Workbook - Set wb = Build.openWorkbook(project.fileName) - NamedRanges.exportNamedRanges wb - MsgBox "Finished exporting code for: " & project.name - - On Error GoTo 0 - Exit Sub -exportVbProject_Error: - ErrorHandling.handleError "Menu.exportVbProject" -End Sub - - -Public Sub importVbProject(ByVal projectName As String) - On Error GoTo importVbProject_Error - - Dim project As VBProject - Set project = Application.VBE.VBProjects(projectName) - Build.importVbaCode project - Dim wb As Workbook - Set wb = Build.openWorkbook(project.fileName) - NamedRanges.importNamedRanges wb - MsgBox "Finished importing code for: " & project.name - - On Error GoTo 0 - Exit Sub -importVbProject_Error: - ErrorHandling.handleError "Menu.importVbProject" -End Sub - - -Public Sub formatVbProject(ByVal projectName As String) - On Error GoTo formatVbProject_Error - - Dim project As VBProject - Set project = Application.VBE.VBProjects(projectName) - Formatter.formatProject project - MsgBox "Finished formatting code for: " & project.name & vbNewLine _ - & vbNewLine _ - & "Did you know you can also format your code, while writing it, by typing 'application.Run ""format""' in the immediate window?" - - On Error GoTo 0 - Exit Sub -formatVbProject_Error: - ErrorHandling.handleError "Menu.formatVbProject" -End Sub - - -Public Sub exportXML(ByVal fileShortName As String) - 'Ask them if they want to save the file first. Warn that existing files could be overwritten. Default to 'Cancel' - Dim validateChoice As Integer, prompt As String, title As String - prompt = "Are you sure you want to export " & fileShortName & " to XML? Any previously exported XML data for that file will be overwritten." - title = "Overwrite existing XML?" - validateChoice = MsgBox(prompt, vbYesNoCancel, title) - - prompt = "Do you want to save the file before exporting? If unsaved, the exported version will reflect only changes until your most recent save." - title = "Save file first?" - validateChoice = MsgBox(prompt, vbYesNoCancel, title) - If validateChoice = vbCancel Then Exit Sub - If validateChoice = vbYes Then - Dim wkb As Workbook - Set wkb = Workbooks(fileShortName) - wkb.Save - End If - - Call unpackXML(fileShortName) - MsgBox ("File successfully exported to XML. Check the 'src' folder where the file is saved.") -End Sub - -Public Sub rebuildXML() - 'This sub lets the user browse to a folder, sets the destination folder as two levels up the folder tree, and then calls the 'rebuildXML' function to zip up the XML data into an Excel file - Dim destinationFolder As String, containingFolderName As String, errorFlag As Boolean, errorMessage As String - destinationFolder = "C:\" - containingFolderName = "C:\" - - containingFolderName = GetFolder(destinationFolder) 'Select containing folder using file picker - containingFolderName = XMLexporter.removeSlash(containingFolderName) 'Remove trailing slash if it exists - - 'destinationFolder is two levels up from the containing folder - On Error GoTo folderError - destinationFolder = containingFolderName - destinationFolder = Left(destinationFolder, Len(destinationFolder) - (Len(destinationFolder) - InStrRev(destinationFolder, "\") + 1)) 'up one level - destinationFolder = Left(destinationFolder, Len(destinationFolder) - (Len(destinationFolder) - InStrRev(destinationFolder, "\") + 1)) 'up another level - On Error GoTo 0 - - errorFlag = False - Call XMLexporter.rebuildXML(destinationFolder, containingFolderName, errorFlag, errorMessage) - -folderError: - If Err.Number <> 0 Then - errorFlag = True - errorMessage = "That's not a valid folder" - End If - - 'Report the status to the user - If errorFlag = True Then - MsgBox (errorMessage) - Else - MsgBox ("File succesfully rebuilt to here: " & vbCrLf & destinationFolder) - End If - -End Sub - -Function GetFolder(InitDir As String) As String - Dim fldr As FileDialog - Dim sItem As String - sItem = InitDir - Set fldr = Application.FileDialog(msoFileDialogFolderPicker) - With fldr - .title = "Select a Folder" - .AllowMultiSelect = False - If Right(sItem, 1) <> "\" Then - sItem = sItem & "\" - End If - .InitialFileName = sItem - If .Show <> -1 Then - sItem = InitDir - Else - sItem = .SelectedItems(1) - End If - End With - GetFolder = sItem - Set fldr = Nothing -End Function +Attribute VB_Name = "Menu" +Option Explicit + +Private Const MENU_TITLE = "VbaDeveloper" +Private Const XML_MENU_TITLE = "XML Import-Export" +Private Const MENU_REFRESH = "Refresh this menu" + + +Public Sub createMenu() + Dim rootMenu As CommandBarPopup + + 'Add the top-level menu to the ribbon Add-ins section + Set rootMenu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _ + Before:=10, _ + Temporary:=True) + rootMenu.caption = MENU_TITLE + + Dim exSubMenu As CommandBarPopup + Dim imSubMenu As CommandBarPopup + Dim formatSubMenu As CommandBarPopup + Set exSubMenu = addSubmenu(rootMenu, 1, "Export code for ...") + Set imSubMenu = addSubmenu(rootMenu, 2, "Import code for ...") + Set formatSubMenu = addSubmenu(rootMenu, 3, "Format code for ...") + addMenuSeparator rootMenu + Dim refreshItem As CommandBarButton + Set refreshItem = addMenuItem(rootMenu, "Menu.refreshMenu", MENU_REFRESH) + refreshItem.FaceId = 37 + + ' menuItem.FaceId = FaceId ' set a picture + Dim vProject As Variant + For Each vProject In Application.VBE.VBProjects + ' We skip over unsaved projects where project.fileName throws error + On Error GoTo nextProject + Dim project As VBProject + Set project = vProject + Dim projectName As String, caption As String + + projectName = project.name + caption = projectName & " (" & Dir(project.fileName) & ")" '<- this can throw error + + Dim exCommand As String, imCommand As String, formatCommand As String + exCommand = "'Menu.exportVbProject """ & projectName & """'" + imCommand = "'Menu.importVbProject """ & projectName & """'" + formatCommand = "'Menu.formatVbProject """ & projectName & """'" + + addMenuItem exSubMenu, exCommand, caption + addMenuItem imSubMenu, imCommand, caption + addMenuItem formatSubMenu, formatCommand, caption +nextProject: + Next vProject + On Error GoTo 0 'reset the error handling + + 'Add menu items for creating and rebuilding XML files + Dim xmlMenu As CommandBarPopup, exXmlSubMenu As CommandBarPopup + Set xmlMenu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, _ + Before:=10, _ + Temporary:=True) + xmlMenu.caption = XML_MENU_TITLE + + Set exXmlSubMenu = addSubmenu(xmlMenu, 1, "Export XML for ...") + Dim rebuildButton As CommandBarButton + Set rebuildButton = addMenuItem(xmlMenu, "Menu.rebuildXML", "Rebuild a file") + rebuildButton.FaceId = 35 + Set refreshItem = addMenuItem(xmlMenu, "Menu.refreshMenu", MENU_REFRESH) + refreshItem.FaceId = 37 + + 'add menu items for all open files + Dim fileName As String + Dim openFile As Workbook + For Each openFile In Application.Workbooks + fileName = openFile.name + Call addMenuItem(exXmlSubMenu, "'Menu.exportXML """ & fileName & """'", fileName) + Next openFile + +End Sub + + +Private Function addMenuItem(menu As CommandBarPopup, ByVal onAction As String, ByVal caption As String) As CommandBarButton + Dim menuItem As CommandBarButton + Set menuItem = menu.Controls.Add(Type:=msoControlButton) + menuItem.onAction = onAction + menuItem.caption = caption + Set addMenuItem = menuItem +End Function + + +Private Function addSubmenu(menu As CommandBarPopup, ByVal position As Integer, ByVal caption As String) As CommandBarPopup + Dim subMenu As CommandBarPopup + Set subMenu = menu.Controls.Add(Type:=msoControlPopup) + subMenu.onAction = position + subMenu.caption = caption + Set addSubmenu = subMenu +End Function + + +Private Sub addMenuSeparator(menuItem As CommandBarPopup) + menuItem.BeginGroup = True +End Sub + + +'This sub should be executed when the workbook is closed +Public Sub deleteMenu() + 'For each control, check if its name matches the names of our custom menus - using this method deletes multiple instances of the menu in case duplicates are mistakenly created. + Dim cbControl + On Error Resume Next + For Each cbControl In CommandBars(1).Controls 'TODO if more menus are added, should use a collection instead of multiple if statements (keep code DRY) + If cbControl.caption = MENU_TITLE Then + Debug.Print "Deleting" & MENU_TITLE + cbControl.Delete + End If + If cbControl.caption = XML_MENU_TITLE Then + Debug.Print "Deleting" & XML_MENU_TITLE + cbControl.Delete + End If + Next cbControl + On Error GoTo 0 +End Sub + +Public Sub refreshMenu() + menu.deleteMenu + menu.createMenu +End Sub + +Public Sub exportVbProject(ByVal projectName As String) + On Error GoTo exportVbProject_Error + + Dim project As VBProject + Set project = Application.VBE.VBProjects(projectName) + Build.exportVbaCode project + Dim wb As Workbook + Set wb = Build.openWorkbook(project.fileName) + NamedRanges.exportNamedRanges wb + MsgBox "Finished exporting code for: " & project.name + + On Error GoTo 0 + Exit Sub +exportVbProject_Error: + ErrorHandling.handleError "Menu.exportVbProject" +End Sub + + +Public Sub importVbProject(ByVal projectName As String) + On Error GoTo importVbProject_Error + + Dim project As VBProject + Set project = Application.VBE.VBProjects(projectName) + Build.importVbaCode project + Dim wb As Workbook + Set wb = Build.openWorkbook(project.fileName) + NamedRanges.importNamedRanges wb + MsgBox "Finished importing code for: " & project.name + + On Error GoTo 0 + Exit Sub +importVbProject_Error: + ErrorHandling.handleError "Menu.importVbProject" +End Sub + + +Public Sub formatVbProject(ByVal projectName As String) + On Error GoTo formatVbProject_Error + + Dim project As VBProject + Set project = Application.VBE.VBProjects(projectName) + Formatter.formatProject project + MsgBox "Finished formatting code for: " & project.name & vbNewLine _ + & vbNewLine _ + & "Did you know you can also format your code, while writing it, by typing 'application.Run ""format""' in the immediate window?" + + On Error GoTo 0 + Exit Sub +formatVbProject_Error: + ErrorHandling.handleError "Menu.formatVbProject" +End Sub + + +Public Sub exportXML(ByVal fileShortName As String) + 'Ask them if they want to save the file first. Warn that existing files could be overwritten. Default to 'Cancel' + Dim validateChoice As Integer, prompt As String, title As String + prompt = "Are you sure you want to export " & fileShortName & " to XML? Any previously exported XML data for that file will be overwritten." + title = "Overwrite existing XML?" + validateChoice = MsgBox(prompt, vbYesNoCancel, title) + + prompt = "Do you want to save the file before exporting? If unsaved, the exported version will reflect only changes until your most recent save." + title = "Save file first?" + validateChoice = MsgBox(prompt, vbYesNoCancel, title) + If validateChoice = vbCancel Then Exit Sub + If validateChoice = vbYes Then + Dim wkb As Workbook + Set wkb = Workbooks(fileShortName) + wkb.Save + End If + + Call unpackXML(fileShortName) + MsgBox ("File successfully exported to XML. Check the 'src' folder where the file is saved.") +End Sub + +Public Sub rebuildXML() + 'This sub lets the user browse to a folder, sets the destination folder as two levels up the folder tree, and then calls the 'rebuildXML' function to zip up the XML data into an Excel file + Dim destinationFolder As String, containingFolderName As String, errorFlag As Boolean, errorMessage As String + destinationFolder = "C:\" + containingFolderName = "C:\" + + containingFolderName = GetFolder(destinationFolder) 'Select containing folder using file picker + containingFolderName = XMLexporter.removeSlash(containingFolderName) 'Remove trailing slash if it exists + + 'destinationFolder is two levels up from the containing folder + On Error GoTo folderError + destinationFolder = containingFolderName + destinationFolder = Left(destinationFolder, Len(destinationFolder) - (Len(destinationFolder) - InStrRev(destinationFolder, "\") + 1)) 'up one level + destinationFolder = Left(destinationFolder, Len(destinationFolder) - (Len(destinationFolder) - InStrRev(destinationFolder, "\") + 1)) 'up another level + On Error GoTo 0 + + errorFlag = False + Call XMLexporter.rebuildXML(destinationFolder, containingFolderName, errorFlag, errorMessage) + +folderError: + If Err.Number <> 0 Then + errorFlag = True + errorMessage = "That's not a valid folder" + End If + + 'Report the status to the user + If errorFlag = True Then + MsgBox (errorMessage) + Else + MsgBox ("File succesfully rebuilt to here: " & vbCrLf & destinationFolder) + End If + +End Sub + +Function GetFolder(InitDir As String) As String + Dim fldr As FileDialog + Dim sItem As String + sItem = InitDir + Set fldr = Application.FileDialog(msoFileDialogFolderPicker) + With fldr + .title = "Select a Folder" + .AllowMultiSelect = False + If Right(sItem, 1) <> "\" Then + sItem = sItem & "\" + End If + .InitialFileName = sItem + If .Show <> -1 Then + sItem = InitDir + Else + sItem = .SelectedItems(1) + End If + End With + GetFolder = sItem + Set fldr = Nothing +End Function diff --git a/src/vbaDeveloper.xlam/MyCustomActions.cls b/src/vbaDeveloper.xlam/MyCustomActions.cls index 6f341b9..db8732b 100644 --- a/src/vbaDeveloper.xlam/MyCustomActions.cls +++ b/src/vbaDeveloper.xlam/MyCustomActions.cls @@ -1,47 +1,47 @@ -VERSION 1.0 CLASS -BEGIN - MultiUse = -1 'True -END -Attribute VB_Name = "MyCustomActions" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = False -Attribute VB_PredeclaredId = False -Attribute VB_Exposed = False -Option Explicit - -Implements CustomActions -' This class serves as an example only. - - -Private Const MY_FAVORITE_WORKBOOK_PATH As String = "C:\path\to\myFavoriteWorkbook\" -Private Const MY_FAVORITE_WORKBOOK_NAME As String = "example.xlsm" - - -' Doc: See CustomActions -Private Sub CustomActions_afterOpen() - On Error GoTo CustomActions_afterOpen_Error - - If Not IsWorkBookOpen(MY_FAVORITE_WORKBOOK_NAME) Then - ' The next line usually raises an error, therefore it is commented out. - 'Application.Workbooks.Open (MY_FAVORITE_WORKBOOK_PATH & MY_FAVORITE_WORKBOOK_NAME) - End If - - On Error GoTo 0 - Exit Sub -CustomActions_afterOpen_Error: - ErrorHandling.handleError "vbaDeveloper.MyCustomActions afterOpen" -End Sub - -' Doc: See CustomActions -Private Sub CustomActions_beforeClose() -End Sub - -Function IsWorkBookOpen(wkbName As String) As Boolean - Dim wBook As Workbook - On Error Resume Next - Set wBook = Workbooks(wkbName) - IsWorkBookOpen = Not (wBook Is Nothing) - On Error GoTo 0 -End Function - - +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "MyCustomActions" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Implements CustomActions +' This class serves as an example only. + + +Private Const MY_FAVORITE_WORKBOOK_PATH As String = "C:\path\to\myFavoriteWorkbook\" +Private Const MY_FAVORITE_WORKBOOK_NAME As String = "example.xlsm" + + +' Doc: See CustomActions +Private Sub CustomActions_afterOpen() + On Error GoTo CustomActions_afterOpen_Error + + If Not IsWorkBookOpen(MY_FAVORITE_WORKBOOK_NAME) Then + ' The next line usually raises an error, therefore it is commented out. + 'Application.Workbooks.Open (MY_FAVORITE_WORKBOOK_PATH & MY_FAVORITE_WORKBOOK_NAME) + End If + + On Error GoTo 0 + Exit Sub +CustomActions_afterOpen_Error: + ErrorHandling.handleError "vbaDeveloper.MyCustomActions afterOpen" +End Sub + +' Doc: See CustomActions +Private Sub CustomActions_beforeClose() +End Sub + +Function IsWorkBookOpen(wkbName As String) As Boolean + Dim wBook As Workbook + On Error Resume Next + Set wBook = Workbooks(wkbName) + IsWorkBookOpen = Not (wBook Is Nothing) + On Error GoTo 0 +End Function + + diff --git a/src/vbaDeveloper.xlam/NamedRanges.bas b/src/vbaDeveloper.xlam/NamedRanges.bas index 3d3bd08..c1d4cc3 100644 --- a/src/vbaDeveloper.xlam/NamedRanges.bas +++ b/src/vbaDeveloper.xlam/NamedRanges.bas @@ -1,110 +1,110 @@ -Attribute VB_Name = "NamedRanges" -Option Explicit - -Private Const NAMED_RANGES_FILE_NAME As String = "NamedRanges.csv" - -Private Enum columns - name = 0 - RefersTo - Comments -End Enum - - -' Import named ranges from csv file -' Existing ranges with the same identifier will be replaced. -Public Sub importNamedRanges(wb As Workbook) - Dim importDir As String - importDir = Build.getSourceDir(wb.FullName, createIfNotExists:=False) - If importDir = "" Then - Debug.Print "No import directory for workbook " & wb.name & ", skipping" - Exit Sub - End If - - Dim fileName As String - fileName = importDir & NAMED_RANGES_FILE_NAME - Dim FSO As New Scripting.FileSystemObject - If FSO.FileExists(fileName) Then - Dim inStream As TextStream - Set inStream = FSO.OpenTextFile(fileName, ForReading, Create:=False) - Dim line As String - Do Until inStream.AtEndOfStream - line = inStream.ReadLine - importName wb, line - Loop - inStream.Close - End If -End Sub - - -Private Sub importName(wb As Workbook, line As String) - Dim parts As Variant - parts = Split(line, ",") - Dim rangeName As String, rangeAddress As String, comment As String - rangeName = parts(columns.name) - rangeAddress = parts(columns.RefersTo) - comment = parts(columns.Comments) - - ' Existing namedRanges don't need to be removed first. - ' wb.Names.Add will automatically replace or add the given namedRange. - wb.Names.Add(rangeName, rangeAddress).comment = comment -End Sub - - -'Export named ranges to csv file -Public Sub exportNamedRanges(wb As Workbook) - Dim exportDir As String - exportDir = Build.getSourceDir(wb.FullName, createIfNotExists:=True) - Dim fileName As String - fileName = exportDir & NAMED_RANGES_FILE_NAME - - Dim lines As Collection - Set lines = New Collection - Dim aName As name - Dim t As Variant - For Each t In wb.Names - Set aName = t - If hasValidRange(aName) Then - lines.Add aName.name & "," & aName.RefersTo & "," & aName.comment - End If - Next - If lines.Count > 0 Then - 'We have some names to export - Debug.Print "writing to " & fileName - - Dim FSO As New Scripting.FileSystemObject - Dim outStream As TextStream - Set outStream = FSO.CreateTextFile(fileName, overwrite:=True, unicode:=False) - On Error GoTo closeStream - Dim line As Variant - For Each line In lines - outStream.WriteLine line - Next line -closeStream: - outStream.Close - End If -End Sub - - -Private Function hasValidRange(aName As name) As Boolean - On Error GoTo no - hasValidRange = False - Dim aRange As Range - Set aRange = aName.RefersToRange - hasValidRange = True -no: -End Function - - -' Clean up all named ranges that don't refer to a valid range. -' This sub is not used by the import and export functions. -' It is provided only for convenience and can be run manually. -Public Sub removeInvalidNamedRanges(wb As Workbook) - Dim aName As name - Dim t As Variant - For Each t In wb.Names - Set aName = t - If Not hasValidRange(aName) Then - aName.Delete - End If - Next -End Sub +Attribute VB_Name = "NamedRanges" +Option Explicit + +Private Const NAMED_RANGES_FILE_NAME As String = "NamedRanges.csv" + +Private Enum columns + name = 0 + RefersTo + Comments +End Enum + + +' Import named ranges from csv file +' Existing ranges with the same identifier will be replaced. +Public Sub importNamedRanges(wb As Workbook) + Dim importDir As String + importDir = Build.getSourceDir(wb.FullName, createIfNotExists:=False) + If importDir = "" Then + Debug.Print "No import directory for workbook " & wb.name & ", skipping" + Exit Sub + End If + + Dim fileName As String + fileName = importDir & NAMED_RANGES_FILE_NAME + Dim FSO As New Scripting.FileSystemObject + If FSO.FileExists(fileName) Then + Dim inStream As TextStream + Set inStream = FSO.OpenTextFile(fileName, ForReading, Create:=False) + Dim line As String + Do Until inStream.AtEndOfStream + line = inStream.ReadLine + importName wb, line + Loop + inStream.Close + End If +End Sub + + +Private Sub importName(wb As Workbook, line As String) + Dim parts As Variant + parts = Split(line, ",") + Dim rangeName As String, rangeAddress As String, comment As String + rangeName = parts(columns.name) + rangeAddress = parts(columns.RefersTo) + comment = parts(columns.Comments) + + ' Existing namedRanges don't need to be removed first. + ' wb.Names.Add will automatically replace or add the given namedRange. + wb.Names.Add(rangeName, rangeAddress).comment = comment +End Sub + + +'Export named ranges to csv file +Public Sub exportNamedRanges(wb As Workbook) + Dim exportDir As String + exportDir = Build.getSourceDir(wb.FullName, createIfNotExists:=True) + Dim fileName As String + fileName = exportDir & NAMED_RANGES_FILE_NAME + + Dim lines As Collection + Set lines = New Collection + Dim aName As name + Dim t As Variant + For Each t In wb.Names + Set aName = t + If hasValidRange(aName) Then + lines.Add aName.name & "," & aName.RefersTo & "," & aName.comment + End If + Next + If lines.Count > 0 Then + 'We have some names to export + Debug.Print "writing to " & fileName + + Dim FSO As New Scripting.FileSystemObject + Dim outStream As TextStream + Set outStream = FSO.CreateTextFile(fileName, overwrite:=True, unicode:=False) + On Error GoTo closeStream + Dim line As Variant + For Each line In lines + outStream.WriteLine line + Next line +closeStream: + outStream.Close + End If +End Sub + + +Private Function hasValidRange(aName As name) As Boolean + On Error GoTo no + hasValidRange = False + Dim aRange As Range + Set aRange = aName.RefersToRange + hasValidRange = True +no: +End Function + + +' Clean up all named ranges that don't refer to a valid range. +' This sub is not used by the import and export functions. +' It is provided only for convenience and can be run manually. +Public Sub removeInvalidNamedRanges(wb As Workbook) + Dim aName As name + Dim t As Variant + For Each t In wb.Names + Set aName = t + If Not hasValidRange(aName) Then + aName.Delete + End If + Next +End Sub diff --git a/src/vbaDeveloper.xlam/Test.bas b/src/vbaDeveloper.xlam/Test.bas index 5956712..3636aef 100644 --- a/src/vbaDeveloper.xlam/Test.bas +++ b/src/vbaDeveloper.xlam/Test.bas @@ -1,200 +1,200 @@ -Attribute VB_Name = "Test" - -Option Explicit - -Private Type myOwn - name As String - age As Integer - car As Variant -End Type - -Enum forTesting - the = 1 - code - Formatter -End Enum - -Public Enum forFormatTesting - the = 2 - code - Formatter -End Enum - -Private Enum rettamrof - the = 3 - code - Formatter -End Enum - -Public Sub testMyCustomActions_Open() - Dim myCustomAction As Object - myCustomAction.afterOpen -End Sub - - -Public Sub testImport() - Dim proj_name As String - proj_name = "vbaDeveloper" - - Dim vbaProject As Object - Set vbaProject = Application.VBE.VBProjects(proj_name) - Build.importVbaCode vbaProject -End Sub - - -Public Sub testExport() - Dim proj_name As String - proj_name = "vbaDeveloper" - - menu.exportVbProject proj_name -End Sub - - -' Now we add some code to try out all the types of formatting -' this is to test the Formatter module - -Private Property Get wbaWords() As Dictionary - Set wbaWords = New Dictionary -End Property - -Public Property Let meSleep(ByVal s As String) - s = "hello" -End Property - -Property Get vaWords() As Dictionary - Set vaWords = wbaWords -End Property - - -Property Let vaWords(x As Dictionary) - Dim y As Object - Set y = x -End Property - -Private Sub anotherPrivateSub() - anotherPublicFunction - Dim y As Integer - y = 4 - Do Until y = 0 - Select Case y - Case 3, 4, 5 'Do nothing - Case 2 To 22 - 'do nothing else - 'do nothing else - Case 1: - Dim x - x = y + x - x = y * y - Select Case x - 'A nested case statement - Case Is < 0: - Err.Raise vbError + 1, "Test", "Did not expect that x < 0" - Case 4, 16, 64: - x = x / 2 - Case 1, 3, 5 - Debug.Print "x is not 6" - End Select - x = x * y - Case Else - Dim z As Integer - z = y - y = y + 4 - End Select - y = y - 1 - Loop - y = 5 -End Sub - -Public Function anotherPublicFunction() As String - ' Lets do a for loop - Dim myCollection As Collection - Dim x - For Each x In myCollection - Debug.Print x - Dim thisMethod, doesnt, matter, dont, thiscode - x.doesNotHave thisMethod - If 2 Then - x.butThat doesnt, matter - Else - 'comments are indented - If False Then - 'just like other code - 'we don't do anything here - ElseIf True Then - becauseWe dont.Run, thiscode - 'this comment - Else - 'also indents - If x > 0 Then - 'x is positive - x = 0 - ElseIf x > -5 Then - x = -5 - Else - Debug.Print "x is less than -5" - End If - End If - End If - Debug.Print "we should not forget the indentation for nested stuff" - Next x -End Function - -Private Function becauseWe(x, y) As Variant - On Error GoTo jail - 'now we do an indexed for loop - Dim i As Integer - For i = 1 To 5 - Debug.Print i - If True Then - Else - 'there was only false - End If - Next -jail: - MsgBox "Error occurred!", , "you are now in jail" -End Function - -Function withoutAccessModifier() - ' and a do while loop - Dim y As Integer - Dim finished As Boolean - finished = False - 'this is also not: -'alabel: -'andthis: - Do While Not finished - y = y + 1 - If y = 10 Then - finished = True - End If - Loop -End Function - -Sub aSubWithoutAccessModifier(that As Variant, _ - has As String, _ - A As Integer, _ - lot As Integer, _ - of As Variant, Optional _ - parameters As String = "default") - - Dim p As Object -somelabel: - 'the next line - 'is not a label: - With p - .codeIsNotSupposedToReachHere - End With -anotherLabel: - -End Sub - -Sub testIsLabel() - Dim line1 As String, line2 As String - line1 = "'somelabel:" - line2 = "some label:" - Debug.Print InStr(line2, " ") - Debug.Print InStr(" ", line2) -End Sub - -' some more comments -' end this is the last line +Attribute VB_Name = "Test" + +Option Explicit + +Private Type myOwn + name As String + age As Integer + car As Variant +End Type + +Enum forTesting + the = 1 + code + Formatter +End Enum + +Public Enum forFormatTesting + the = 2 + code + Formatter +End Enum + +Private Enum rettamrof + the = 3 + code + Formatter +End Enum + +Public Sub testMyCustomActions_Open() + Dim myCustomAction As Object + myCustomAction.afterOpen +End Sub + + +Public Sub testImport() + Dim proj_name As String + proj_name = "vbaDeveloper" + + Dim vbaProject As Object + Set vbaProject = Application.VBE.VBProjects(proj_name) + Build.importVbaCode vbaProject +End Sub + + +Public Sub testExport() + Dim proj_name As String + proj_name = "vbaDeveloper" + + menu.exportVbProject proj_name +End Sub + + +' Now we add some code to try out all the types of formatting +' this is to test the Formatter module + +Private Property Get wbaWords() As Dictionary + Set wbaWords = New Dictionary +End Property + +Public Property Let meSleep(ByVal s As String) + s = "hello" +End Property + +Property Get vaWords() As Dictionary + Set vaWords = wbaWords +End Property + + +Property Let vaWords(x As Dictionary) + Dim y As Object + Set y = x +End Property + +Private Sub anotherPrivateSub() + anotherPublicFunction + Dim y As Integer + y = 4 + Do Until y = 0 + Select Case y + Case 3, 4, 5 'Do nothing + Case 2 To 22 + 'do nothing else + 'do nothing else + Case 1: + Dim x + x = y + x + x = y * y + Select Case x + 'A nested case statement + Case Is < 0: + Err.Raise vbError + 1, "Test", "Did not expect that x < 0" + Case 4, 16, 64: + x = x / 2 + Case 1, 3, 5 + Debug.Print "x is not 6" + End Select + x = x * y + Case Else + Dim z As Integer + z = y + y = y + 4 + End Select + y = y - 1 + Loop + y = 5 +End Sub + +Public Function anotherPublicFunction() As String + ' Lets do a for loop + Dim myCollection As Collection + Dim x + For Each x In myCollection + Debug.Print x + Dim thisMethod, doesnt, matter, dont, thiscode + x.doesNotHave thisMethod + If 2 Then + x.butThat doesnt, matter + Else + 'comments are indented + If False Then + 'just like other code + 'we don't do anything here + ElseIf True Then + becauseWe dont.Run, thiscode + 'this comment + Else + 'also indents + If x > 0 Then + 'x is positive + x = 0 + ElseIf x > -5 Then + x = -5 + Else + Debug.Print "x is less than -5" + End If + End If + End If + Debug.Print "we should not forget the indentation for nested stuff" + Next x +End Function + +Private Function becauseWe(x, y) As Variant + On Error GoTo jail + 'now we do an indexed for loop + Dim i As Integer + For i = 1 To 5 + Debug.Print i + If True Then + Else + 'there was only false + End If + Next +jail: + MsgBox "Error occurred!", , "you are now in jail" +End Function + +Function withoutAccessModifier() + ' and a do while loop + Dim y As Integer + Dim finished As Boolean + finished = False + 'this is also not: +'alabel: +'andthis: + Do While Not finished + y = y + 1 + If y = 10 Then + finished = True + End If + Loop +End Function + +Sub aSubWithoutAccessModifier(that As Variant, _ + has As String, _ + A As Integer, _ + lot As Integer, _ + of As Variant, Optional _ + parameters As String = "default") + + Dim p As Object +somelabel: + 'the next line + 'is not a label: + With p + .codeIsNotSupposedToReachHere + End With +anotherLabel: + +End Sub + +Sub testIsLabel() + Dim line1 As String, line2 As String + line1 = "'somelabel:" + line2 = "some label:" + Debug.Print InStr(line2, " ") + Debug.Print InStr(" ", line2) +End Sub + +' some more comments +' end this is the last line diff --git a/src/vbaDeveloper.xlam/ThisWorkbook.sheet.cls b/src/vbaDeveloper.xlam/ThisWorkbook.sheet.cls index 07516a4..a9181d4 100644 --- a/src/vbaDeveloper.xlam/ThisWorkbook.sheet.cls +++ b/src/vbaDeveloper.xlam/ThisWorkbook.sheet.cls @@ -1,30 +1,30 @@ -Option Explicit - -'' The classes EventListener, CustomActions, MyCustomActions are not imported automatically by the build module. -'' After they are imported manually, the comments below can be uncommented. This will enable automatic code exports on save -'' and automatic code imports on open. - - -' Private listener As EventListener -' Private customAction As CustomActions - -'' Initialize member to listen to excel events -Private Sub Workbook_Open() - Debug.Print "vbaDeveloper thisWorkbook_open()" - ' Set listener = New EventListener - ' Set customAction = New MyCustomActions - menu.createMenu - ' customAction.afterOpen -End Sub - - -'' Clean up our private members -Private Sub Workbook_BeforeClose(Cancel As Boolean) - Debug.Print "vbaDeveloper thisWorkbook_BeforeClose()" - menu.deleteMenu - ' If Not customAction Is Nothing Then - ' customAction.BeforeClose - ' Set customAction = Nothing - ' End If - ' Set listener = Nothing +Option Explicit + +'' The classes EventListener, CustomActions, MyCustomActions are not imported automatically by the build module. +'' After they are imported manually, the comments below can be uncommented. This will enable automatic code exports on save +'' and automatic code imports on open. + + +' Private listener As EventListener +' Private customAction As CustomActions + +'' Initialize member to listen to excel events +Private Sub Workbook_Open() + Debug.Print "vbaDeveloper thisWorkbook_open()" + ' Set listener = New EventListener + ' Set customAction = New MyCustomActions + menu.createMenu + ' customAction.afterOpen +End Sub + + +'' Clean up our private members +Private Sub Workbook_BeforeClose(Cancel As Boolean) + Debug.Print "vbaDeveloper thisWorkbook_BeforeClose()" + menu.deleteMenu + ' If Not customAction Is Nothing Then + ' customAction.BeforeClose + ' Set customAction = Nothing + ' End If + ' Set listener = Nothing End Sub \ No newline at end of file diff --git a/src/vbaDeveloper.xlam/XMLexporter.bas b/src/vbaDeveloper.xlam/XMLexporter.bas index acc5091..353d975 100644 --- a/src/vbaDeveloper.xlam/XMLexporter.bas +++ b/src/vbaDeveloper.xlam/XMLexporter.bas @@ -1,192 +1,192 @@ -Attribute VB_Name = "XMLexporter" -Public Const XML_FOLDER_NAME = "XMLsource\" -Public Const TEMP_ZIP_NAME = "temp.zip" - -Sub test_unpackXML() - Call unpackXML("tempDevFile.xlsm") - MsgBox ("Done") -End Sub - -Public Sub unpackXML(fileShortName As String) - 'This unpacks the most recently saved version of the file that is passed as an argument. - 'It's necessary for the file to be currently open; calling function should (if appropriate) ask the user if they want to save before executing so that the version on the hard drive is the most recent. - - Dim fileName As String, exportPath As String, exportPathXML As String - fileName = Workbooks(fileShortName).FullName - exportPath = getSourceDir(fileName, createIfNotExists:=True) - exportPathXML = exportPath & XML_FOLDER_NAME - - Dim FSO As New Scripting.FileSystemObject - If Not FSO.FolderExists(exportPathXML) Then - FSO.CreateFolder exportPathXML - Debug.Print "Created Folder " & exportPathXML - End If - - 'Copy file to temp zip file - Dim tempZipFileName As String - tempZipFileName = exportPath & TEMP_ZIP_NAME - 'FileCopy fileName, tempZipFileName - FSO.CopyFile fileName, tempZipFileName, True - - 'unzip the temp zip file to the folder - Call Unzip(tempZipFileName, exportPathXML) - - 'delete the temp zip file - Kill tempZipFileName - -End Sub - -Sub Unzip(Fname As Variant, DefPath As String) - 'Code modified from example found here: http://www.rondebruin.nl/win/s7/win002.htm - Dim FSO As Object - Dim oApp As Object - Dim FileNameFolder As Variant - - If Fname = False Then - 'Do nothing - Else - DefPath = addSlash(DefPath) - FileNameFolder = DefPath - - 'Delete all the files in the folder DefPath first if you want - On Error Resume Next - Clear_All_Files_And_SubFolders_In_Folder (DefPath) - On Error GoTo 0 - - 'Extract the files into the Destination folder - Set oApp = CreateObject("Shell.Application") - oApp.Namespace("" & FileNameFolder).CopyHere oApp.Namespace("" & Fname).Items 'The ""& is to address a bug - for some reason VBA doesn't like to use the passed strings in this situation. Found discussion on this here: http://forums.codeguru.com/showthread.php?443782-CreateObject(-quot-Shell-Application-quot-)-Error - - On Error Resume Next - Set FSO = CreateObject("scripting.filesystemobject") - FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True - End If -End Sub - - -Sub Clear_All_Files_And_SubFolders_In_Folder(MyPath As String) - 'Delete all files and subfolders - 'Be sure that no file is open in the folder - If Right(MyPath, 1) = "\" Then - MyPath = Left(MyPath, Len(MyPath) - 1) - End If - - Dim FSO As Object - Set FSO = CreateObject("scripting.filesystemobject") - - If FSO.FolderExists(MyPath) = False Then - MsgBox MyPath & " doesn't exist" - Exit Sub - End If - - On Error Resume Next - 'Delete files - FSO.DeleteFile MyPath & "\*.*", True - 'Delete subfolders - FSO.DeleteFolder MyPath & "\*.*", True - On Error GoTo 0 - -End Sub - -Sub test_rebuildXML() - Dim destinationFolder As String, containingFolderName As String, errorFlag As Boolean, errorMessage As String - destinationFolder = "C:\_files\Git\vbaDeveloper" - containingFolderName = "C:\_files\Git\vbaDeveloper\src\tempDevFile.xlsm" - errorFlag = False - - Call rebuildXML(destinationFolder, containingFolderName, errorFlag, errorMessage) - - If errorFlag = True Then - MsgBox (errorMessage) - Else - MsgBox ("Done!") - End If - -End Sub - -Public Sub rebuildXML(destinationFolder As String, containingFolderName As String, errorFlag As Boolean, errorMessage As String) - - 'input format cleanup - containing folder name should not have trailing "\" - containingFolderName = removeSlash(containingFolderName) - destinationFolder = removeSlash(destinationFolder) - - 'Make sure that the containingFolderName has an XML subfolder - Dim xmlFolderName As String - xmlFolderName = containingFolderName & "\" & XML_FOLDER_NAME - Set FSO = CreateObject("scripting.filesystemobject") - If FSO.FolderExists(xmlFolderName) = False Then - errorMessage = "We couldn't find XML data in that folder. Make sure you pick the folder under /src that is named the same as the Excel to be rebuilt, and that it contains XML data." - errorFlag = True - Exit Sub - End If - - 'Set what some items should be named - Dim fileExtension As String, strDate As String, fileShortName As String, fileName As String, zipFileName As String - strDate = VBA.format(Now, " yyyy-mm-dd hh-mm-ss") - fileExtension = "." & Right(containingFolderName, Len(containingFolderName) - InStrRev(containingFolderName, ".")) 'The containing folder is the folder that is under \src and that is named the same thing as the target file (folder is filename.xlsx) - can parse file ending out of folder - fileShortName = Right(containingFolderName, Len(containingFolderName) - InStrRev(containingFolderName, "\")) 'This should be just the final folder name - fileShortName = Left(fileShortName, Len(fileShortName) - (Len(fileShortName) - InStr(fileShortName, ".")) - 1) 'remove the extension, since we've saved that separately. - fileName = destinationFolder & "\" & fileShortName & "-rebuilt" & strDate & fileExtension - - zipFileName = containingFolderName & "\" & TEMP_ZIP_NAME - - 'Make sure we're not accidentally overwriting anything - this should be rare - If FSO.FileExists(zipFileName) Then - errorMessage = "There is already a file named " & TEMP_ZIP_NAME & " in the folder " & containingFolderName & ". This file needs to be removed before continuing." - errorFlag = True - Exit Sub - End If - - 'Zip the folder into the FileNameZip - Call Zip_All_Files_in_Folder(xmlFolderName, zipFileName) - - 'Rename the zipFileName to be the fileName (this effectively removes the zip file) - Name zipFileName As fileName - errorFlag = False - -End Sub - - - -Sub Zip_All_Files_in_Folder(FolderName As Variant, FileNameZip As Variant) - 'Code modified from example found here: http://www.rondebruin.nl/win/s7/win001.htm - Dim strDate As String, DefPath As String - Dim oApp As Object - - 'Create empty Zip File - NewZip (FileNameZip) - - Set oApp = CreateObject("Shell.Application") - 'Copy the files to the compressed folder - oApp.Namespace("" & FileNameZip).CopyHere oApp.Namespace("" & FolderName).Items '""& added due to bug in VBA - - 'Keep script waiting until Compressing is done - On Error Resume Next - Do Until oApp.Namespace("" & FileNameZip).Items.Count = _ - oApp.Namespace("" & FolderName).Items.Count - Application.Wait (Now + TimeValue("0:00:01")) - Loop - On Error GoTo 0 -End Sub - -Sub NewZip(sPath) - 'Create empty Zip File - 'Changed by keepITcool Dec-12-2005 - If Len(Dir(sPath)) > 0 Then Kill sPath - Open sPath For Output As #1 - Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) - Close #1 -End Sub - -Function removeSlash(strFolder) As String - If Right(strFolder, 1) = "\" Then - strFolder = Left(strFolder, Len(strFolder) - 1) - End If - removeSlash = strFolder -End Function -Function addSlash(strFolder) As String - If Right(strFolder, 1) <> "\" Then - strFolder = strFolder & "\" - End If - addSlash = strFolder -End Function +Attribute VB_Name = "XMLexporter" +Public Const XML_FOLDER_NAME = "XMLsource\" +Public Const TEMP_ZIP_NAME = "temp.zip" + +Sub test_unpackXML() + Call unpackXML("tempDevFile.xlsm") + MsgBox ("Done") +End Sub + +Public Sub unpackXML(fileShortName As String) + 'This unpacks the most recently saved version of the file that is passed as an argument. + 'It's necessary for the file to be currently open; calling function should (if appropriate) ask the user if they want to save before executing so that the version on the hard drive is the most recent. + + Dim fileName As String, exportPath As String, exportPathXML As String + fileName = Workbooks(fileShortName).FullName + exportPath = getSourceDir(fileName, createIfNotExists:=True) + exportPathXML = exportPath & XML_FOLDER_NAME + + Dim FSO As New Scripting.FileSystemObject + If Not FSO.FolderExists(exportPathXML) Then + FSO.CreateFolder exportPathXML + Debug.Print "Created Folder " & exportPathXML + End If + + 'Copy file to temp zip file + Dim tempZipFileName As String + tempZipFileName = exportPath & TEMP_ZIP_NAME + 'FileCopy fileName, tempZipFileName + FSO.CopyFile fileName, tempZipFileName, True + + 'unzip the temp zip file to the folder + Call Unzip(tempZipFileName, exportPathXML) + + 'delete the temp zip file + Kill tempZipFileName + +End Sub + +Sub Unzip(Fname As Variant, DefPath As String) + 'Code modified from example found here: http://www.rondebruin.nl/win/s7/win002.htm + Dim FSO As Object + Dim oApp As Object + Dim FileNameFolder As Variant + + If Fname = False Then + 'Do nothing + Else + DefPath = addSlash(DefPath) + FileNameFolder = DefPath + + 'Delete all the files in the folder DefPath first if you want + On Error Resume Next + Clear_All_Files_And_SubFolders_In_Folder (DefPath) + On Error GoTo 0 + + 'Extract the files into the Destination folder + Set oApp = CreateObject("Shell.Application") + oApp.Namespace("" & FileNameFolder).CopyHere oApp.Namespace("" & Fname).Items 'The ""& is to address a bug - for some reason VBA doesn't like to use the passed strings in this situation. Found discussion on this here: http://forums.codeguru.com/showthread.php?443782-CreateObject(-quot-Shell-Application-quot-)-Error + + On Error Resume Next + Set FSO = CreateObject("scripting.filesystemobject") + FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True + End If +End Sub + + +Sub Clear_All_Files_And_SubFolders_In_Folder(MyPath As String) + 'Delete all files and subfolders + 'Be sure that no file is open in the folder + If Right(MyPath, 1) = "\" Then + MyPath = Left(MyPath, Len(MyPath) - 1) + End If + + Dim FSO As Object + Set FSO = CreateObject("scripting.filesystemobject") + + If FSO.FolderExists(MyPath) = False Then + MsgBox MyPath & " doesn't exist" + Exit Sub + End If + + On Error Resume Next + 'Delete files + FSO.DeleteFile MyPath & "\*.*", True + 'Delete subfolders + FSO.DeleteFolder MyPath & "\*.*", True + On Error GoTo 0 + +End Sub + +Sub test_rebuildXML() + Dim destinationFolder As String, containingFolderName As String, errorFlag As Boolean, errorMessage As String + destinationFolder = "C:\_files\Git\vbaDeveloper" + containingFolderName = "C:\_files\Git\vbaDeveloper\src\tempDevFile.xlsm" + errorFlag = False + + Call rebuildXML(destinationFolder, containingFolderName, errorFlag, errorMessage) + + If errorFlag = True Then + MsgBox (errorMessage) + Else + MsgBox ("Done!") + End If + +End Sub + +Public Sub rebuildXML(destinationFolder As String, containingFolderName As String, errorFlag As Boolean, errorMessage As String) + + 'input format cleanup - containing folder name should not have trailing "\" + containingFolderName = removeSlash(containingFolderName) + destinationFolder = removeSlash(destinationFolder) + + 'Make sure that the containingFolderName has an XML subfolder + Dim xmlFolderName As String + xmlFolderName = containingFolderName & "\" & XML_FOLDER_NAME + Set FSO = CreateObject("scripting.filesystemobject") + If FSO.FolderExists(xmlFolderName) = False Then + errorMessage = "We couldn't find XML data in that folder. Make sure you pick the folder under /src that is named the same as the Excel to be rebuilt, and that it contains XML data." + errorFlag = True + Exit Sub + End If + + 'Set what some items should be named + Dim fileExtension As String, strDate As String, fileShortName As String, fileName As String, zipFileName As String + strDate = VBA.format(Now, " yyyy-mm-dd hh-mm-ss") + fileExtension = "." & Right(containingFolderName, Len(containingFolderName) - InStrRev(containingFolderName, ".")) 'The containing folder is the folder that is under \src and that is named the same thing as the target file (folder is filename.xlsx) - can parse file ending out of folder + fileShortName = Right(containingFolderName, Len(containingFolderName) - InStrRev(containingFolderName, "\")) 'This should be just the final folder name + fileShortName = Left(fileShortName, Len(fileShortName) - (Len(fileShortName) - InStr(fileShortName, ".")) - 1) 'remove the extension, since we've saved that separately. + fileName = destinationFolder & "\" & fileShortName & "-rebuilt" & strDate & fileExtension + + zipFileName = containingFolderName & "\" & TEMP_ZIP_NAME + + 'Make sure we're not accidentally overwriting anything - this should be rare + If FSO.FileExists(zipFileName) Then + errorMessage = "There is already a file named " & TEMP_ZIP_NAME & " in the folder " & containingFolderName & ". This file needs to be removed before continuing." + errorFlag = True + Exit Sub + End If + + 'Zip the folder into the FileNameZip + Call Zip_All_Files_in_Folder(xmlFolderName, zipFileName) + + 'Rename the zipFileName to be the fileName (this effectively removes the zip file) + Name zipFileName As fileName + errorFlag = False + +End Sub + + + +Sub Zip_All_Files_in_Folder(FolderName As Variant, FileNameZip As Variant) + 'Code modified from example found here: http://www.rondebruin.nl/win/s7/win001.htm + Dim strDate As String, DefPath As String + Dim oApp As Object + + 'Create empty Zip File + NewZip (FileNameZip) + + Set oApp = CreateObject("Shell.Application") + 'Copy the files to the compressed folder + oApp.Namespace("" & FileNameZip).CopyHere oApp.Namespace("" & FolderName).Items '""& added due to bug in VBA + + 'Keep script waiting until Compressing is done + On Error Resume Next + Do Until oApp.Namespace("" & FileNameZip).Items.Count = _ + oApp.Namespace("" & FolderName).Items.Count + Application.Wait (Now + TimeValue("0:00:01")) + Loop + On Error GoTo 0 +End Sub + +Sub NewZip(sPath) + 'Create empty Zip File + 'Changed by keepITcool Dec-12-2005 + If Len(Dir(sPath)) > 0 Then Kill sPath + Open sPath For Output As #1 + Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) + Close #1 +End Sub + +Function removeSlash(strFolder) As String + If Right(strFolder, 1) = "\" Then + strFolder = Left(strFolder, Len(strFolder) - 1) + End If + removeSlash = strFolder +End Function +Function addSlash(strFolder) As String + If Right(strFolder, 1) <> "\" Then + strFolder = strFolder & "\" + End If + addSlash = strFolder +End Function From fd6458905c514a36721bd6b62a1aef28eb4a64cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20K=C3=BCnzli?= Date: Sun, 12 Feb 2017 02:34:48 +0100 Subject: [PATCH 3/6] import defaults to include classes - fixes #1 --- src/vbaDeveloper.xlam/Build.bas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/vbaDeveloper.xlam/Build.bas b/src/vbaDeveloper.xlam/Build.bas index bb83163..9508cf0 100644 --- a/src/vbaDeveloper.xlam/Build.bas +++ b/src/vbaDeveloper.xlam/Build.bas @@ -166,9 +166,9 @@ Private Sub exportLines(exportPath As String, component As VBComponent) End Sub -' Usually called after the given workbook is opened. The option includeClassFiles is False by default because -' they don't import correctly from VBA. They'll have to be imported manually instead. -Public Sub importVbaCode(vbaProject As VBProject, Optional includeClassFiles As Boolean = False) +' Usually called after the given workbook is opened. +' The option includeClassFiles is True by default providing that git repo is correctly handling line endings as crlf (Windows-style) instead of lf (Unix-style) +Public Sub importVbaCode(vbaProject As VBProject, Optional includeClassFiles As Boolean = True) Dim vbProjectFileName As String On Error Resume Next 'this can throw if the workbook has never been saved. From b59ff7711eb8ca548cc8950a4a6aa3f919191680 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20K=C3=BCnzli?= Date: Sun, 12 Feb 2017 05:00:58 +0100 Subject: [PATCH 4/6] import defaults to include classes - fixes #1 --- src/vbaDeveloper.xlam/Build.bas | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/vbaDeveloper.xlam/Build.bas b/src/vbaDeveloper.xlam/Build.bas index bb83163..9508cf0 100644 --- a/src/vbaDeveloper.xlam/Build.bas +++ b/src/vbaDeveloper.xlam/Build.bas @@ -166,9 +166,9 @@ Private Sub exportLines(exportPath As String, component As VBComponent) End Sub -' Usually called after the given workbook is opened. The option includeClassFiles is False by default because -' they don't import correctly from VBA. They'll have to be imported manually instead. -Public Sub importVbaCode(vbaProject As VBProject, Optional includeClassFiles As Boolean = False) +' Usually called after the given workbook is opened. +' The option includeClassFiles is True by default providing that git repo is correctly handling line endings as crlf (Windows-style) instead of lf (Unix-style) +Public Sub importVbaCode(vbaProject As VBProject, Optional includeClassFiles As Boolean = True) Dim vbProjectFileName As String On Error Resume Next 'this can throw if the workbook has never been saved. From 7665e34b51574d676999e2a55b60c483254c1728 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20K=C3=BCnzli?= Date: Sun, 12 Feb 2017 06:18:29 +0100 Subject: [PATCH 5/6] #2 Export JSON description of forms --- .gitignore | 10 +- src/vbaDeveloper.xlam/Build.bas | 11 +- src/vbaDeveloper.xlam/BuildForm.bas | 231 +++++ src/vbaDeveloper.xlam/Dictionary.cls | 459 +++++++++ src/vbaDeveloper.xlam/EventListener.cls | 1 + src/vbaDeveloper.xlam/FormSerializer.bas | 637 ++++++++++++ src/vbaDeveloper.xlam/Formatter.bas | 2 +- src/vbaDeveloper.xlam/JsonConverter.bas | 1134 ++++++++++++++++++++++ src/vbaDeveloper.xlam/XMLexporter.bas | 2 +- 9 files changed, 2476 insertions(+), 11 deletions(-) create mode 100644 src/vbaDeveloper.xlam/BuildForm.bas create mode 100644 src/vbaDeveloper.xlam/Dictionary.cls create mode 100644 src/vbaDeveloper.xlam/FormSerializer.bas create mode 100644 src/vbaDeveloper.xlam/JsonConverter.bas diff --git a/.gitignore b/.gitignore index 3c5e591..8298e96 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ -*.xlam -*.xlsm -*.xlsx -*.xla -*.xls +/*.xlam +/*.xlsm +/*.xlsx +/*.xla +/*.xls diff --git a/src/vbaDeveloper.xlam/Build.bas b/src/vbaDeveloper.xlam/Build.bas index 9508cf0..559dc04 100644 --- a/src/vbaDeveloper.xlam/Build.bas +++ b/src/vbaDeveloper.xlam/Build.bas @@ -21,7 +21,6 @@ Attribute VB_Name = "Build" Option Explicit - Private Const IMPORT_DELAY As String = "00:00:03" 'We need to make these variables public such that they can be given as arguments to application.ontime() @@ -35,7 +34,7 @@ Public Sub testImport() Dim vbaProject As Object Set vbaProject = Application.VBE.VBProjects(proj_name) - Build.importVbaCode vbaProject + Build.importVbaCode vbaProject, True End Sub @@ -122,7 +121,7 @@ Public Sub exportVbaCode(vbaProject As VBProject) Case vbext_ct_StdModule exportComponent export_path, component, ".bas" Case vbext_ct_MSForm - exportComponent export_path, component, ".frm" + BuildForm.exportMSForm export_path, component Case vbext_ct_Document exportLines export_path, component Case Else @@ -293,8 +292,12 @@ End Sub ' Assumes any component with same name has already been removed. Private Sub importComponent(vbaProject As VBProject, filePath As String) Debug.Print "Importing component from " & filePath - 'This next line is a bug! It imports all classes as modules! vbaProject.VBComponents.Import filePath + Dim newComp As VBComponent + Set newComp = vbaProject.VBComponents.Import(filePath) + Do While Trim(newComp.codeModule.lines(1, 1)) = "" And newComp.codeModule.CountOfLines > 1 + newComp.codeModule.DeleteLines 1 + Loop End Sub diff --git a/src/vbaDeveloper.xlam/BuildForm.bas b/src/vbaDeveloper.xlam/BuildForm.bas new file mode 100644 index 0000000..3f65a17 --- /dev/null +++ b/src/vbaDeveloper.xlam/BuildForm.bas @@ -0,0 +1,231 @@ +Attribute VB_Name = "BuildForm" +'' +' BuildForm v1.0.0 +' (c) Georges Kuenzli - https://github.com/gkuenzli/vbaDeveloper +' +' `BuildForm` exports a MSForm to 3 files : +' - .frm : code of the component +' - .frx : OLE ActiveX binary data => design data of the component +' - .frd : JSON data => human-readable design data of the component +' +' @module FormSerializer +' @author gkuenzli +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +Private Const USERFORM_DATA_EXT As String = ".frd" +Private Const USERFORM_CODE_EXT As String = ".frm" +Private Const USERFORM_XOLE_EXT As String = ".frx" + + +'' +' Export a MSForm to the specified path +' Do export component parts only when a change is detected +' +' @method exportMSForm +' @param {String} exportPath +' @param {VBComponent} component +'' +Public Sub exportMSForm(exportPath As String, component As VBComponent) + Dim FSO As New Scripting.FileSystemObject + Dim frxChanged As Boolean + Dim frmChanged As Boolean + Dim storedFilePath As String + Dim tempFilePath As String + Dim tempFolder As String + + storedFilePath = JoinPath(exportPath, component.name) + + ' Create temporary folder + tempFolder = storedFilePath & "~" + If Not FSO.FolderExists(tempFolder) Then + FSO.CreateFolder tempFolder + End If + tempFilePath = JoinPath(tempFolder, component.name) + + ' Export component to temporary files + component.Export tempFilePath & USERFORM_CODE_EXT + + ' Comparing MSForm data (stored vs current) + Dim storedData As String + Dim currentData As String + storedData = loadMSFormData(exportPath, component) + currentData = FormSerializer.SerializeMSForm(component) + frxChanged = getCleanCode(storedData) <> getCleanCode(currentData) + + ' Comparing MSForm code (stored vs current, hence temporary) + Dim storedCode As String + Dim currentCode As String + storedCode = getCleanCode(loadTextFile(storedFilePath & USERFORM_CODE_EXT)) + currentCode = getCleanCode(getCleanFormHeader(loadTextFile(tempFilePath & USERFORM_CODE_EXT))) + frmChanged = storedCode <> currentCode + + ' Persist changed elements + If frxChanged Then + Debug.Print "exporting " & component.name & USERFORM_XOLE_EXT + DeleteFile storedFilePath & USERFORM_XOLE_EXT + FSO.MoveFile tempFilePath & USERFORM_XOLE_EXT, storedFilePath & USERFORM_XOLE_EXT + Debug.Print "exporting " & component.name & USERFORM_DATA_EXT + saveTextFile storedFilePath & USERFORM_DATA_EXT, currentData + End If + If frmChanged Then + Debug.Print "exporting " & component.name & USERFORM_CODE_EXT + saveTextFile storedFilePath & USERFORM_CODE_EXT, currentCode + End If + + ' Clean temporary files + On Error Resume Next + FSO.DeleteFile tempFilePath & ".*", True + FSO.DeleteFolder tempFolder, True + On Error GoTo 0 +End Sub + +Private Sub DeleteFile(ByVal fileName As String) + Dim FSO As New Scripting.FileSystemObject + If FSO.FileExists(fileName) Then + FSO.DeleteFile fileName + End If +End Sub + +Private Function loadMSFormData(ByVal exportPath As String, ByVal component As VBComponent) As String + loadMSFormData = loadTextFile(getMSFormFileName(exportPath, component)) +End Function + +Public Function loadTextFile(ByVal fileName As String) As String + Dim FSO As New Scripting.FileSystemObject + Dim inStream As TextStream + + ' Check if data file does exist + If Not FSO.FileExists(fileName) Then + Debug.Print "loadTextFile skipped because " & fileName & " does not exist" + Exit Function + End If + + ' Read data file contents + Set inStream = FSO.OpenTextFile(fileName, ForReading, False) + loadTextFile = inStream.ReadAll + inStream.Close +End Function + +Public Sub saveTextFile(ByVal fileName As String, ByVal text As String) + Dim FSO As New Scripting.FileSystemObject + Dim outStream As TextStream + Set outStream = FSO.CreateTextFile(fileName, True, False) + outStream.Write text + outStream.Close +End Sub + +Private Function getMSFormFileName(ByVal exportPath As String, ByVal component As VBComponent) As String + getMSFormFileName = exportPath & "\" & component.name & USERFORM_DATA_EXT +End Function + +Private Function isCodeIdentical(ByVal component As VBComponent, ByVal otherVersion As String) As Boolean + Dim compVersion As String + compVersion = getComponentCode(component) + isCodeIdentical = getCleanCode(compVersion) = getCleanCode(otherVersion) +End Function + +Private Function getCleanCode(ByVal code As String) As String + getCleanCode = RemoveTrailingEmptyLines(RemoveLeadingEmptyLines(code)) +End Function + +Private Function getComponentCode(ByVal component As VBComponent) As String + getComponentCode = component.codeModule.lines(1, component.codeModule.CountOfLines) +End Function + +Public Function RemoveLeadingEmptyLines(ByVal text As String) As String + Do + text = LTrim(text) + If Left(text, 2) = vbCrLf Then + text = Mid(text, 3) + Else + RemoveLeadingEmptyLines = text + Exit Function + End If + Loop +End Function + +Public Function RemoveTrailingEmptyLines(ByVal text As String) As String + Do + text = LTrim(text) + If Right(text, 2) = vbCrLf Then + text = Left(text, Len(text) - 2) + Else + RemoveTrailingEmptyLines = text & vbCrLf + Exit Function + End If + Loop +End Function + +Public Function getCleanFormHeader(ByVal userFormCode As String) As String + Dim lns + Dim i As Long + Dim startLn As Long + Dim removeLns As Long + Dim seenAttribute As Boolean + Dim inCode As Boolean + lns = Split(userFormCode, vbCrLf) + For i = LBound(lns) To UBound(lns) + ' Found end of header ? + If Not seenAttribute Then + If InStr(lns(i), "Attribute") = 1 Then + seenAttribute = True + End If + ElseIf startLn = 0 Then + If InStr(lns(i), "Attribute") <> 1 Then + startLn = i - 1 + End If + End If + If startLn > 0 And Not inCode Then + If Trim(lns(i)) = "" Then + removeLns = removeLns + 1 + Else + If removeLns = 0 Then + getCleanFormHeader = userFormCode + Exit Function + End If + inCode = True + End If + End If + If inCode Then + lns(i - removeLns) = lns(i) + End If + Next i + ReDim Preserve lns(UBound(lns) - removeLns) + getCleanFormHeader = Join(lns, vbCrLf) +End Function + + +'' +' Join Path with \ +' +' @example +' ```VB.net +' Debug.Print JoinPath("a/", "/b") +' Debug.Print JoinPath("a", "b") +' Debug.Print JoinPath("a/", "b") +' Debug.Print JoinPath("a", "/b") +' -> a/b +' ``` +' +' @param {String} LeftSide +' @param {String} RightSide +' @return {String} Joined path +'' +Public Function JoinPath(LeftSide As String, RightSide As String) As String + If Left(RightSide, 1) = "\" Then + RightSide = Right(RightSide, Len(RightSide) - 1) + End If + If Right(LeftSide, 1) = "\" Then + LeftSide = Left(LeftSide, Len(LeftSide) - 1) + End If + + If LeftSide <> "" And RightSide <> "" Then + JoinPath = LeftSide & "\" & RightSide + Else + JoinPath = LeftSide & RightSide + End If +End Function + + diff --git a/src/vbaDeveloper.xlam/Dictionary.cls b/src/vbaDeveloper.xlam/Dictionary.cls new file mode 100644 index 0000000..76d083b --- /dev/null +++ b/src/vbaDeveloper.xlam/Dictionary.cls @@ -0,0 +1,459 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Dictionary" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = True +'' +' Dictionary v1.3.0 +' (c) Tim Hall - https://github.com/timhall/VBA-Dictionary +' +' Drop-in replacement for Scripting.Dictionary on Mac +' +' @author: tim.hall.engr@gmail.com +' @license: MIT (http://www.opensource.org/licenses/mit-license.php +' +' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +' --------------------------------------------- ' +' Constants and Private Variables +' --------------------------------------------- ' + +#Const UseScriptingDictionaryIfAvailable = True + +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + +' dict_KeyValue 0: FormattedKey, 1: OriginalKey, 2: Value +Private dict_pKeyValues As Collection +Private dict_pKeys() As Variant +Private dict_pItems() As Variant +Private dict_pObjectKeys As Collection +Private dict_pCompareMode As CompareMethod + +#Else + +Private dict_pDictionary As Object + +#End If + +' --------------------------------------------- ' +' Types +' --------------------------------------------- ' + +Public Enum CompareMethod + BinaryCompare = VBA.vbBinaryCompare + TextCompare = VBA.vbTextCompare + DatabaseCompare = VBA.vbDatabaseCompare +End Enum + +' --------------------------------------------- ' +' Properties +' --------------------------------------------- ' + +Public Property Get CompareMode() As CompareMethod +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + CompareMode = dict_pCompareMode +#Else + CompareMode = dict_pDictionary.CompareMode +#End If +End Property +Public Property Let CompareMode(Value As CompareMethod) +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + If Me.Count > 0 Then + ' Can't change CompareMode for Dictionary that contains data + ' http://msdn.microsoft.com/en-us/library/office/gg278481(v=office.15).aspx + Err.Raise 5 ' Invalid procedure call or argument + End If + + dict_pCompareMode = Value +#Else + dict_pDictionary.CompareMode = Value +#End If +End Property + +Public Property Get Count() As Long +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Count = dict_pKeyValues.Count +#Else + Count = dict_pDictionary.Count +#End If +End Property + +Public Property Get Item(Key As Variant) As Variant +Attribute Item.VB_UserMemId = 0 +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Dim dict_KeyValue As Variant + dict_KeyValue = dict_GetKeyValue(Key) + + If Not IsEmpty(dict_KeyValue) Then + If VBA.IsObject(dict_KeyValue(2)) Then + Set Item = dict_KeyValue(2) + Else + Item = dict_KeyValue(2) + End If + Else + ' Not found -> Returns Empty + End If +#Else + If VBA.IsObject(dict_pDictionary.Item(Key)) Then + Set Item = dict_pDictionary.Item(Key) + Else + Item = dict_pDictionary.Item(Key) + End If +#End If +End Property +Public Property Let Item(Key As Variant, Value As Variant) +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + If Me.Exists(Key) Then + dict_ReplaceKeyValue dict_GetKeyValue(Key), Key, Value + Else + dict_AddKeyValue Key, Value + End If +#Else + dict_pDictionary.Item(Key) = Value +#End If +End Property +Public Property Set Item(Key As Variant, Value As Variant) +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + If Me.Exists(Key) Then + dict_ReplaceKeyValue dict_GetKeyValue(Key), Key, Value + Else + dict_AddKeyValue Key, Value + End If +#Else + Set dict_pDictionary.Item(Key) = Value +#End If +End Property + +Public Property Let Key(Previous As Variant, Updated As Variant) +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Dim dict_KeyValue As Variant + dict_KeyValue = dict_GetKeyValue(Previous) + + If Not VBA.IsEmpty(dict_KeyValue) Then + dict_ReplaceKeyValue dict_KeyValue, Updated, dict_KeyValue(2) + End If +#Else + dict_pDictionary.Key(Previous) = Updated +#End If +End Property + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Add an item with the given key +' +' @param {Variant} Key +' @param {Variant} Item +' --------------------------------------------- ' +Public Sub Add(Key As Variant, Item As Variant) +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + If Not Me.Exists(Key) Then + dict_AddKeyValue Key, Item + Else + ' This key is already associated with an element of this collection + Err.Raise 457 + End If +#Else + dict_pDictionary.Add Key, Item +#End If +End Sub + +'' +' Check if an item exists for the given key +' +' @param {Variant} Key +' @return {Boolean} +' --------------------------------------------- ' +Public Function Exists(Key As Variant) As Boolean +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Exists = Not IsEmpty(dict_GetKeyValue(Key)) +#Else + Exists = dict_pDictionary.Exists(Key) +#End If +End Function + +'' +' Get an array of all items +' +' @return {Variant} +' --------------------------------------------- ' +Public Function Items() As Variant +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + If Me.Count > 0 Then + Items = dict_pItems + Else + ' Split("") creates initialized empty array that matches Dictionary Keys and Items + Items = VBA.Split("") + End If +#Else + Items = dict_pDictionary.Items +#End If +End Function + +'' +' Get an array of all keys +' +' @return {Variant} +' --------------------------------------------- ' +Public Function Keys() As Variant +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + If Me.Count > 0 Then + Keys = dict_pKeys + Else + ' Split("") creates initialized empty array that matches Dictionary Keys and Items + Keys = VBA.Split("") + End If +#Else + Keys = dict_pDictionary.Keys +#End If +End Function + +'' +' Remove an item for the given key +' +' @param {Variant} Key +' --------------------------------------------- ' +Public Sub Remove(Key As Variant) +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Dim dict_KeyValue As Variant + dict_KeyValue = dict_GetKeyValue(Key) + + If Not VBA.IsEmpty(dict_KeyValue) Then + dict_RemoveKeyValue dict_KeyValue + Else + ' Application-defined or object-defined error + Err.Raise 32811 + End If +#Else + dict_pDictionary.Remove Key +#End If +End Sub + +'' +' Remove all items +' --------------------------------------------- ' +Public Sub RemoveAll() +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Set dict_pKeyValues = New Collection + + Erase dict_pKeys + Erase dict_pItems +#Else + dict_pDictionary.RemoveAll +#End If +End Sub + +' ============================================= ' +' Private Functions +' ============================================= ' + +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + +Private Function dict_GetKeyValue(dict_Key As Variant) As Variant + On Error Resume Next + dict_GetKeyValue = dict_pKeyValues(dict_GetFormattedKey(dict_Key)) + Err.Clear +End Function + +Private Sub dict_AddKeyValue(dict_Key As Variant, dict_Value As Variant, Optional dict_Index As Long = -1) + If Me.Count = 0 Then + ReDim dict_pKeys(0 To 0) + ReDim dict_pItems(0 To 0) + Else + ReDim Preserve dict_pKeys(0 To UBound(dict_pKeys) + 1) + ReDim Preserve dict_pItems(0 To UBound(dict_pItems) + 1) + End If + + Dim dict_FormattedKey As String + dict_FormattedKey = dict_GetFormattedKey(dict_Key) + + If dict_Index > 0 And dict_Index <= dict_pKeyValues.Count Then + Dim dict_i As Long + For dict_i = UBound(dict_pKeys) To dict_Index Step -1 + dict_pKeys(dict_i) = dict_pKeys(dict_i - 1) + If VBA.IsObject(dict_pItems(dict_i - 1)) Then + Set dict_pItems(dict_i) = dict_pItems(dict_i - 1) + Else + dict_pItems(dict_i) = dict_pItems(dict_i - 1) + End If + Next dict_i + + dict_pKeys(dict_Index - 1) = dict_Key + If VBA.IsObject(dict_Value) Then + Set dict_pItems(dict_Index - 1) = dict_Value + Else + dict_pItems(dict_Index - 1) = dict_Value + End If + + dict_pKeyValues.Add Array(dict_FormattedKey, dict_Key, dict_Value), dict_FormattedKey, Before:=dict_Index + Else + If VBA.IsObject(dict_Key) Then + Set dict_pKeys(UBound(dict_pKeys)) = dict_Key + Else + dict_pKeys(UBound(dict_pKeys)) = dict_Key + End If + If VBA.IsObject(dict_Value) Then + Set dict_pItems(UBound(dict_pItems)) = dict_Value + Else + dict_pItems(UBound(dict_pItems)) = dict_Value + End If + + dict_pKeyValues.Add Array(dict_FormattedKey, dict_Key, dict_Value), dict_FormattedKey + End If +End Sub + +Private Sub dict_ReplaceKeyValue(dict_KeyValue As Variant, dict_Key As Variant, dict_Value As Variant) + Dim dict_Index As Long + Dim dict_i As Integer + + dict_Index = dict_GetKeyIndex(dict_KeyValue(1)) + + ' Remove existing dict_Value + dict_RemoveKeyValue dict_KeyValue, dict_Index + + ' Add new dict_Key dict_Value back + dict_AddKeyValue dict_Key, dict_Value, dict_Index +End Sub + +Private Sub dict_RemoveKeyValue(dict_KeyValue As Variant, Optional ByVal dict_Index As Long = -1) + Dim dict_i As Long + If dict_Index = -1 Then + dict_Index = dict_GetKeyIndex(dict_KeyValue(1)) + Else + dict_Index = dict_Index - 1 + End If + + If dict_Index >= 0 And dict_Index <= UBound(dict_pKeys) Then + For dict_i = dict_Index To UBound(dict_pKeys) - 1 + dict_pKeys(dict_i) = dict_pKeys(dict_i + 1) + + If VBA.IsObject(dict_pItems(dict_i + 1)) Then + Set dict_pItems(dict_i) = dict_pItems(dict_i + 1) + Else + dict_pItems(dict_i) = dict_pItems(dict_i + 1) + End If + Next dict_i + + If UBound(dict_pKeys) = 0 Then + Erase dict_pKeys + Erase dict_pItems + Else + ReDim Preserve dict_pKeys(0 To UBound(dict_pKeys) - 1) + ReDim Preserve dict_pItems(0 To UBound(dict_pItems) - 1) + End If + End If + + dict_pKeyValues.Remove dict_KeyValue(0) + dict_RemoveObjectKey dict_KeyValue(1) +End Sub + +Private Function dict_GetFormattedKey(dict_Key As Variant) As String + If VBA.IsObject(dict_Key) Then + dict_GetFormattedKey = dict_GetObjectKey(dict_Key) + ElseIf VarType(dict_Key) = VBA.vbBoolean Then + dict_GetFormattedKey = IIf(dict_Key, "-1__-1", "0__0") + ElseIf VarType(dict_Key) = VBA.vbString Then + dict_GetFormattedKey = dict_Key + + If Me.CompareMode = CompareMethod.BinaryCompare Then + ' Collection does not have method of setting key comparison + ' So case-sensitive keys aren't supported by default + ' -> Approach: Append lowercase characters to original key + ' AbC -> AbC___b_, abc -> abc__abc, ABC -> ABC_____ + Dim dict_Lowercase As String + dict_Lowercase = "" + + Dim dict_i As Integer + Dim dict_Char As String + Dim dict_Ascii As Integer + For dict_i = 1 To VBA.Len(dict_GetFormattedKey) + dict_Char = VBA.Mid$(dict_GetFormattedKey, dict_i, 1) + dict_Ascii = VBA.Asc(dict_Char) + If dict_Ascii >= 97 And dict_Ascii <= 122 Then + dict_Lowercase = dict_Lowercase & dict_Char + Else + dict_Lowercase = dict_Lowercase & "_" + End If + Next dict_i + + If dict_Lowercase <> "" Then + dict_GetFormattedKey = dict_GetFormattedKey & "__" & dict_Lowercase + End If + End If + Else + ' For numbers, add duplicate to distinguish from strings + ' -> 123 -> "123__123" + ' "123" -> "123" + dict_GetFormattedKey = VBA.CStr(dict_Key) & "__" & CStr(dict_Key) + End If +End Function + +Private Function dict_GetObjectKey(dict_ObjKey As Variant) As String + Dim dict_i As Integer + For dict_i = 1 To dict_pObjectKeys.Count + If dict_pObjectKeys.Item(dict_i) Is dict_ObjKey Then + dict_GetObjectKey = "__object__" & dict_i + Exit Function + End If + Next dict_i + + dict_pObjectKeys.Add dict_ObjKey + dict_GetObjectKey = "__object__" & dict_pObjectKeys.Count +End Function + +Private Sub dict_RemoveObjectKey(dict_ObjKey As Variant) + Dim dict_i As Integer + For dict_i = 1 To dict_pObjectKeys.Count + If dict_pObjectKeys.Item(dict_i) Is dict_ObjKey Then + dict_pObjectKeys.Remove dict_i + Exit Sub + End If + Next dict_i +End Sub + +Private Function dict_GetKeyIndex(dict_Key As Variant) As Long + Dim dict_i As Long + For dict_i = 0 To UBound(dict_pKeys) + If VBA.IsObject(dict_pKeys(dict_i)) And VBA.IsObject(dict_Key) Then + If dict_pKeys(dict_i) Is dict_Key Then + dict_GetKeyIndex = dict_i + Exit For + End If + ElseIf VBA.IsObject(dict_pKeys(dict_i)) Or VBA.IsObject(dict_Key) Then + ' Both need to be objects to check equality, skip + ElseIf dict_pKeys(dict_i) = dict_Key Then + dict_GetKeyIndex = dict_i + Exit For + End If + Next dict_i +End Function + +#End If + +Private Sub Class_Initialize() +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Set dict_pKeyValues = New Collection + + Erase dict_pKeys + Erase dict_pItems + Set dict_pObjectKeys = New Collection +#Else + Set dict_pDictionary = CreateObject("Scripting.Dictionary") +#End If +End Sub + +Private Sub Class_Terminate() +#If Mac Or Not UseScriptingDictionaryIfAvailable Then + Set dict_pKeyValues = Nothing + Set dict_pObjectKeys = Nothing +#Else + Set dict_pDictionary = Nothing +#End If +End Sub diff --git a/src/vbaDeveloper.xlam/EventListener.cls b/src/vbaDeveloper.xlam/EventListener.cls index 719b269..d09b772 100644 --- a/src/vbaDeveloper.xlam/EventListener.cls +++ b/src/vbaDeveloper.xlam/EventListener.cls @@ -58,6 +58,7 @@ Private Sub App_WorkbookOpen(ByVal wb As Workbook) NamedRanges.importNamedRanges wb End If + Exit Sub App_WorkbookOpen_Error: ErrorHandling.handleError "vbaDeveloper.EventListener WorkbookOpen" diff --git a/src/vbaDeveloper.xlam/FormSerializer.bas b/src/vbaDeveloper.xlam/FormSerializer.bas new file mode 100644 index 0000000..56ab79c --- /dev/null +++ b/src/vbaDeveloper.xlam/FormSerializer.bas @@ -0,0 +1,637 @@ +Attribute VB_Name = "FormSerializer" +'' +' FormSerializer v1.0.0 +' (c) Georges Kuenzli - https://github.com/gkuenzli/vbaDeveloper +' +' `FormSerializer` produces a string JSON description of a MSForm. +' +' @module FormSerializer +' @author gkuenzli +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + + +'' +' Convert a VBComponent of type MSForm to a JSON descriptive data +' +' @method serializeMSForm +' @param {VBComponent} FormComponent +' @return {String} MSForm JSON descriptive data +'' +Public Function SerializeMSForm(ByVal FormComponent As VBComponent) As String + Dim dict As Dictionary + Dim json As String + Set dict = GetMSFormProperties(FormComponent) + json = ConvertToJson(dict, vbTab) + SerializeMSForm = json +End Function + +Private Function GetMSFormProperties(ByVal FormComponent As VBComponent) As Dictionary + Dim dict As New Dictionary + Dim p As Property + dict.Add "Name", FormComponent.name + dict.Add "Designer", GetDesigner(FormComponent) + dict.Add "Properties", GetProperties(FormComponent, FormComponent.Properties) + Set GetMSFormProperties = dict +End Function + +Private Function GetDesigner(ByVal FormComponent As VBComponent) As Dictionary + Dim dict As New Dictionary + dict.Add "Controls", GetControls(FormComponent.Designer.Controls) + Set GetDesigner = dict +End Function + +Private Function GetProperties(ByVal Context As Object, ByVal Properties As Properties) As Dictionary + Dim dict As New Dictionary + Dim props As New Collection + Dim p As Property + Dim i As Long + For i = 1 To Properties.Count + Set p = Properties(i) + If IsSerializableProperty(Context, p) Then + 'props.Add GetProperty(Context, p) + dict.Add p.name, GetValue(Context, p) + End If + Next i + Set GetProperties = dict +End Function + +Private Function IsSerializableProperty(ByVal Context As Object, ByVal Property As Property) As Boolean + Dim tp As VbVarType + On Error Resume Next + tp = VarType(Property.Value) + On Error GoTo 0 + IsSerializableProperty = _ + (tp <> vbEmpty) And (tp <> vbError) And _ + Left(Property.name, 1) <> "_" And _ + InStr("ActiveControls,Controls,Handle,MouseIcon,Picture,Selected,DesignMode,ShowToolbox,ShowGridDots,SnapToGrid,GridX,GridY,DrawBuffer,CanPaste", Property.name) = 0 + + If TypeName(Context) = "VBComponent" Then + ' We must ignore Top and Height MSForm properties since these seem to be related to the some settings in the Windows user profile. + IsSerializableProperty = _ + IsSerializableProperty And _ + InStr("Top,Height", Property.name) = 0 + End If +End Function + +Private Function GetProperty(ByVal Context As Object, ByVal Property As Property) As Dictionary + Dim dict As New Dictionary + dict.Add "Name", Property.name + If Property.name = "Controls" Then + Else + dict.Add "Value", GetValue(Context, Property) + End If + Set GetProperty = dict +End Function + +Private Function GetControls(ByVal Controls As Controls) As Collection + Dim coll As New Collection + Dim ctrl As Control + For Each ctrl In Controls + If Not ControlExistsInSubElements(Controls, ctrl.name, 0) Then + coll.Add GetControl(ctrl) + End If + Next ctrl + Set GetControls = coll +End Function + +Private Function ControlExistsInSubElements(ByVal Controls As Controls, ByVal name As String, ByVal Depth As Long) As Boolean + Dim ctrl As Control + Dim o As Object + For Each ctrl In Controls + Set o = ctrl + If Depth > 0 Then + If name = ctrl.name Then + ControlExistsInSubElements = True + Exit Function + End If + End If + On Error Resume Next + ControlExistsInSubElements = ControlExistsInSubElements(o.Controls, name, Depth + 1) + On Error GoTo 0 + If ControlExistsInSubElements Then + Exit Function + End If + Next ctrl +End Function + +Private Function GetControl(ByVal Control As Control) As Dictionary + Dim dict As New Dictionary + Dim o As Object + Set o = Control + On Error Resume Next + dict.Add "Class", TypeName(o) + dict.Add "Name", Control.name + dict.Add "Cancel", Control.Cancel + dict.Add "ControlSource", Control.ControlSource + dict.Add "ControlTipText", Control.ControlTipText + dict.Add "Default", Control.Default + dict.Add "Height", Control.Height + dict.Add "HelpContextID", Control.HelpContextID + dict.Add "LayoutEffect", Control.LayoutEffect + dict.Add "Left", Control.Left + dict.Add "RowSource", Control.RowSource + dict.Add "RowSourceType", Control.RowSourceType + dict.Add "TabIndex", Control.TabIndex + dict.Add "TabStop", Control.TabStop + dict.Add "Tag", Control.Tag + dict.Add "Top", Control.Top + dict.Add "Visible", Control.Visible + dict.Add "Width", Control.Width + + Select Case TypeName(o) + Case "CheckBox" + AddCheckBox dict, o + Case "ComboBox" + AddComboBox dict, o + Case "CommandButton" + AddCommandButton dict, o + Case "Frame" + AddFrame dict, o + Case "Image" + AddImage dict, o + Case "Label" + AddLabel dict, o + Case "ListBox" + AddListBox dict, o + Case "MultiPage" + AddMultiPage dict, o + Case "OptionButton" + AddOptionButton dict, o + Case "Page" + AddPage dict, o + Case "ScrollBar" + AddScrollBar dict, o + Case "SpinButton" + AddSpinButton dict, o + Case "Tab" + AddTab dict, o + Case "TabStrip" + AddTabStrip dict, o + Case "TextBox" + AddTextBox dict, o + Case "ToggleButton" + AddToggleButton dict, o + Case "RefEdit" + AddRefEdit dict, o + Case Else + Debug.Print "Unknown ActiveX Control Type Name : " & TypeName(o) + End Select + + Set GetControl = dict +End Function + +Private Sub AddCheckBox(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + dict.Add "Alignment", o.Alignment + dict.Add "AutoSize", o.AutoSize + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "Caption", o.caption + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "GroupName", o.GroupName + dict.Add "Locked", o.Locked + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PicturePosition", o.PicturePosition + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "TextAlign", o.TextAlign + dict.Add "TripleState", o.TripleState + dict.Add "Value", o.Value + dict.Add "WordWrap", o.WordWrap +End Sub + +Private Sub AddComboBox(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "AutoSize", o.AutoSize + dict.Add "AutoTab", o.AutoTab + dict.Add "AutoWordSelect", o.AutoWordSelect + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "BorderColor", o.BorderColor + dict.Add "BorderStyle", o.BorderStyle + dict.Add "BoundColumn", o.BoundColumn +' dict.Add "CanPaste", o.CanPaste + dict.Add "ColumnCount", o.ColumnCount + dict.Add "ColumnHeads", o.ColumnHeads + dict.Add "ColumnWidths", o.ColumnWidths + dict.Add "DragBehavior", o.DragBehavior + dict.Add "DropButtonStyle", o.DropButtonStyle + dict.Add "Enabled", o.Enabled + dict.Add "EnterFieldBehavior", o.EnterFieldBehavior + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "HideSelection", o.HideSelection + dict.Add "IMEMode", o.IMEMode + dict.Add "ListRows", o.ListRows + dict.Add "ListStyle", o.ListStyle + dict.Add "ListWidth", o.ListWidth + dict.Add "Locked", o.Locked + dict.Add "MatchEntry", o.MatchEntry + dict.Add "MatchRequired", o.MatchRequired + dict.Add "MaxLength", o.MaxLength + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "SelectionMargin", o.SelectionMargin + dict.Add "ShowDropButtonWhen", o.ShowDropButtonWhen + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "Style", o.Style + dict.Add "Text", o.text + dict.Add "TextAlign", o.TextAlign + dict.Add "TextColumn", o.TextColumn + dict.Add "TopIndex", o.TopIndex + dict.Add "Value", o.Value +End Sub + +Private Sub AddCommandButton(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + dict.Add "AutoSize", o.AutoSize + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "Caption", o.caption + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "Locked", o.Locked + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PicturePosition", o.PicturePosition + dict.Add "TakeFocusOnClick", o.TakeFocusOnClick + dict.Add "WordWrap", o.WordWrap +End Sub + +Private Sub AddFrame(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "BackColor", o.BackColor + dict.Add "BorderColor", o.BorderColor + dict.Add "BorderStyle", o.BorderStyle + 'dict.Add "CanPaste", o.CanPaste + dict.Add "CanRedo", o.CanRedo + dict.Add "CanUndo", o.CanUndo + dict.Add "Caption", o.caption + dict.Add "Controls", GetControls(o.Controls) + dict.Add "Cycle", o.Cycle + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "InsideHeight", o.InsideHeight + dict.Add "InsideWidth", o.InsideWidth + dict.Add "KeepScrollBarsVisible", o.KeepScrollBarsVisible + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PictureAlignment", o.PictureAlignment + dict.Add "PictureSizeMode", o.PictureSizeMode + dict.Add "PictureTiling", o.PictureTiling + dict.Add "ScrollBars", o.ScrollBars + dict.Add "ScrollHeight", o.ScrollHeight + dict.Add "ScrollLeft", o.ScrollLeft + dict.Add "ScrollTop", o.ScrollTop + dict.Add "ScrollWidth", o.ScrollWidth + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "VerticalScrollBarSide", o.VerticalScrollBarSide + dict.Add "Zoom", o.Zoom +End Sub + +Private Sub AddImage(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "AutoSize", o.AutoSize + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "BorderColor", o.BorderColor + dict.Add "BorderStyle", o.BorderStyle + dict.Add "Enabled", o.Enabled + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PictureAlignment", o.PictureAlignment + dict.Add "PictureSizeMode", o.PictureSizeMode + dict.Add "PictureTiling", o.PictureTiling + dict.Add "SpecialEffect", o.SpecialEffect +End Sub + +Private Sub AddLabel(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + dict.Add "AutoSize", o.AutoSize + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "BorderColor", o.BorderColor + dict.Add "BorderStyle", o.BorderStyle + dict.Add "Caption", o.caption + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PicturePosition", o.PicturePosition + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "TextAlign", o.TextAlign + dict.Add "WordWrap", o.WordWrap +End Sub + +Private Sub AddListBox(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "BackColor", o.BackColor + dict.Add "BorderColor", o.BorderColor + dict.Add "BorderStyle", o.BorderStyle + dict.Add "BoundColumn", o.BoundColumn + dict.Add "ColumnHeads", o.ColumnHeads + dict.Add "ColumnWidths", o.ColumnWidths + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "IMEMode", o.IMEMode + dict.Add "IntegralHeight", o.IntegralHeight + dict.Add "ListIndex", o.ListIndex + dict.Add "ListStyle", o.ListStyle + dict.Add "Locked", o.Locked + dict.Add "MatchEntry", o.MatchEntry + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "MultiSelect", o.MultiSelect + dict.Add "Selected", o.Selected + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "Text", o.text + dict.Add "TextAlign", o.TextAlign + dict.Add "TextColumn", o.TextColumn + dict.Add "TopIndex", o.TopIndex + dict.Add "Value", o.Value +End Sub + +Private Sub AddMultiPage(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "BackColor", o.BackColor + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "MultiRow", o.MultiRow + dict.Add "Pages", GetPages(o.Pages) + dict.Add "Style", o.Style + dict.Add "TabFixedHeight", o.TabFixedHeight + dict.Add "TabFixedWidth", o.TabFixedWidth + dict.Add "TabOrientation", o.TabOrientation + dict.Add "Value", o.Value +End Sub + +Private Sub AddOptionButton(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + dict.Add "Alignment", o.Alignment + dict.Add "AutoSize", o.AutoSize + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "Caption", o.caption + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "GroupName", o.GroupName + dict.Add "Locked", o.Locked + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PicturePosition", o.PicturePosition + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "TextAlign", o.TextAlign + dict.Add "TripleState", o.TripleState + dict.Add "Value", o.Value + dict.Add "WordWrap", o.WordWrap +End Sub + +Private Sub AddPage(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + 'dict.Add "CanPaste", o.CanPaste + dict.Add "CanRedo", o.CanRedo + dict.Add "CanUndo", o.CanUndo + dict.Add "Caption", o.caption + dict.Add "Controls", GetControls(o.Controls) + dict.Add "ControlTipText", o.ControlTipText + dict.Add "Cycle", o.Cycle + dict.Add "Enabled", o.Enabled + dict.Add "Index", o.Index + dict.Add "InsideHeight", o.InsideHeight + dict.Add "InsideWidth", o.InsideWidth + dict.Add "KeepScrollBarsVisible", o.KeepScrollBarsVisible + dict.Add "Name", o.name + dict.Add "Parent", o.Parent + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PictureAlignment", o.PictureAlignment + dict.Add "PictureSizeMode", o.PictureSizeMode + dict.Add "PictureTiling", o.PictureTiling + dict.Add "ScrollBars", o.ScrollBars + dict.Add "ScrollHeight", o.ScrollHeight + dict.Add "ScrollLeft", o.ScrollLeft + dict.Add "ScrollTop", o.ScrollTop + dict.Add "ScrollWidth", o.ScrollWidth + dict.Add "Tag", o.Tag + dict.Add "TransitionEffect", o.TransitionEffect + dict.Add "TransitionPeriod", o.TransitionPeriod + dict.Add "VerticalScrollBarSide", o.VerticalScrollBarSide + dict.Add "Visible", o.Visible + dict.Add "Zoom", o.Zoom +End Sub + +Private Sub AddScrollBar(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "BackColor", o.BackColor + dict.Add "Delay", o.Delay + dict.Add "Enabled", o.Enabled + dict.Add "ForeColor", o.ForeColor + dict.Add "LargeChange", o.LargeChange + dict.Add "Max", o.Max + dict.Add "Min", o.Min + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Orientation", o.Orientation + dict.Add "ProportionalThumb", o.ProportionalThumb + dict.Add "SmallChange", o.SmallChange + dict.Add "Value", o.Value +End Sub + +Private Sub AddSpinButton(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "BackColor", o.BackColor + dict.Add "Delay", o.Delay + dict.Add "Enabled", o.Enabled + dict.Add "ForeColor", o.ForeColor + dict.Add "Max", o.Max + dict.Add "Min", o.Min + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Orientation", o.Orientation + dict.Add "SmallChange", o.SmallChange + dict.Add "Value", o.Value +End Sub + +Private Sub AddTab(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + dict.Add "Caption", o.caption + dict.Add "ControlTipText", o.ControlTipText + dict.Add "Enabled", o.Enabled + dict.Add "Index", o.Index + dict.Add "Name", o.name + dict.Add "Tag", o.Tag + dict.Add "Visible", o.Visible +End Sub + +Private Sub AddTabStrip(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "BackColor", o.BackColor + dict.Add "ClientHeight", o.ClientHeight + dict.Add "ClientLeft", o.ClientLeft + dict.Add "ClientTop", o.ClientTop + dict.Add "ClientWidth", o.ClientWidth + dict.Add "Enabled", o.Enabled + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "MultiRow", o.MultiRow + dict.Add "SelectedItem", o.SelectedItem + dict.Add "Style", o.Style + dict.Add "TabFixedHeight", o.TabFixedHeight + dict.Add "TabFixedWidth", o.TabFixedWidth + dict.Add "TabOrientation", o.TabOrientation + dict.Add "Tabs", GetTabs(o.Tabs) + dict.Add "Value", o.Value +End Sub + +Private Sub AddTextBox(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "AutoSize", o.AutoSize + dict.Add "AutoTab", o.AutoTab + dict.Add "AutoWordSelect", o.AutoWordSelect + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "BorderColor", o.BorderColor + dict.Add "BorderStyle", o.BorderStyle + 'dict.Add "CanPaste", o.CanPaste + dict.Add "CurLine", o.CurLine + dict.Add "DragBehavior", o.DragBehavior + dict.Add "Enabled", o.Enabled + dict.Add "EnterFieldBehavior", o.EnterFieldBehavior + dict.Add "EnterKeyBehavior", o.EnterKeyBehavior + dict.Add "Font", GetFont(o.Font) + dict.Add "ForeColor", o.ForeColor + dict.Add "HideSelection", o.HideSelection + dict.Add "IMEMode", o.IMEMode + dict.Add "IntegralHeight", o.IntegralHeight + dict.Add "Locked", o.Locked + dict.Add "MaxLength", o.MaxLength + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "MultiLine", o.MultiLine + dict.Add "PasswordChar", o.PasswordChar + dict.Add "ScrollBars", o.ScrollBars + dict.Add "SelectionMargin", o.SelectionMargin + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "TabKeyBehavior", o.TabKeyBehavior + dict.Add "Text", o.text + dict.Add "TextAlign", o.TextAlign + dict.Add "Value", o.Value + dict.Add "WordWrap", o.WordWrap +End Sub + +Private Sub AddToggleButton(ByVal dict As Dictionary, ByVal o As Object) + On Error Resume Next + dict.Add "Accelerator", o.Accelerator + dict.Add "Alignment", o.Alignment + dict.Add "AutoSize", o.AutoSize + dict.Add "BackColor", o.BackColor + dict.Add "BackStyle", o.BackStyle + dict.Add "Caption", o.caption + dict.Add "Enabled", o.Enabled + dict.Add "ForeColor", o.ForeColor + dict.Add "GroupName", o.GroupName + dict.Add "Locked", o.Locked + dict.Add "MouseIcon", GetPicture(o.MouseIcon) + dict.Add "MousePointer", o.MousePointer + dict.Add "Picture", GetPicture(o.Picture) + dict.Add "PicturePosition", o.PicturePosition + dict.Add "SpecialEffect", o.SpecialEffect + dict.Add "TextAlign", o.TextAlign + dict.Add "TripleState", o.TripleState + dict.Add "Value", o.Value + dict.Add "WordWrap", o.WordWrap +End Sub + +Private Sub AddRefEdit(ByVal dict As Dictionary, ByVal o As Object) + AddComboBox dict, o + On Error Resume Next +End Sub + +Private Function GetPages(ByVal Pages As MSForms.Pages) As Collection + Dim coll As New Collection + Dim i As Long + Dim p As MSForms.Page + For i = 0 To Pages.Count - 1 + Set p = Pages(i) + coll.Add GetPage(p) + Next i + Set GetPages = coll +End Function + +Private Function GetPage(ByVal Page As MSForms.Page) As Dictionary + Dim dict As New Dictionary + AddPage dict, Page + Set GetPage = dict +End Function + +Private Function GetTabs(ByVal Tabs As Tabs) As Collection + Dim coll As New Collection + Dim i As Long + Dim p As MSForms.Tab + For i = 0 To Tabs.Count - 1 + Set p = Tabs(i) + coll.Add GetTab(p) + Next i + Set GetTabs = coll +End Function + +Private Function GetTab(ByVal t As MSForms.Tab) As Dictionary + Dim dict As New Dictionary + AddTab dict, t + Set GetTab = dict +End Function + +Private Function GetFont(ByVal Font As NewFont) As Dictionary + Dim dict As New Dictionary + dict.Add "Bold", Font.Bold + dict.Add "Charset", Font.Charset + dict.Add "Italic", Font.Italic + dict.Add "Name", Font.name + dict.Add "Size", Font.size + dict.Add "Strikethrough", Font.Strikethrough + dict.Add "Underline", Font.Underline + dict.Add "Weight", Font.Weight + Set GetFont = dict +End Function + +Private Function GetPicture(ByVal Picture As IPictureDisp) As String + + ' TODO: implement a Base64-encoding of the picture + +End Function + +Private Function GetValue(ByVal Context As Object, ByVal Property As Property) As Variant + If VarType(Property.Value) = vbObject Then + Select Case TypeName(Property.Value) + Case "Properties" + Set GetValue = GetProperties(Context, Property.Value) + Case Else + Set GetValue = Nothing + End Select + Else + GetValue = Property.Value + End If +End Function diff --git a/src/vbaDeveloper.xlam/Formatter.bas b/src/vbaDeveloper.xlam/Formatter.bas index 5f9eb6c..a805ac6 100644 --- a/src/vbaDeveloper.xlam/Formatter.bas +++ b/src/vbaDeveloper.xlam/Formatter.bas @@ -189,7 +189,7 @@ Public Sub formatProject(vbaProject As VBProject) Next End Sub -Public Sub format() +Public Sub Format() formatCode Application.VBE.ActiveCodePane.codeModule End Sub diff --git a/src/vbaDeveloper.xlam/JsonConverter.bas b/src/vbaDeveloper.xlam/JsonConverter.bas new file mode 100644 index 0000000..bf0547a --- /dev/null +++ b/src/vbaDeveloper.xlam/JsonConverter.bas @@ -0,0 +1,1134 @@ +Attribute VB_Name = "JsonConverter" +'' +' VBA-JSON v2.2.2 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON +' +' JSON Converter for VBA +' +' Errors: +' 10001 - JSON parse error +' +' @class JsonConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +' +' Based originally on vba-json (with extensive changes) +' BSD license included below +' +' JSONLib, http://code.google.com/p/vba-json/ +' +' Copyright (c) 2013, Ryo Yokoyama +' All rights reserved. +' +' Redistribution and use in source and binary forms, with or without +' modification, are permitted provided that the following conditions are met: +' * Redistributions of source code must retain the above copyright +' notice, this list of conditions and the following disclaimer. +' * Redistributions in binary form must reproduce the above copyright +' notice, this list of conditions and the following disclaimer in the +' documentation and/or other materials provided with the distribution. +' * Neither the name of the nor the +' names of its contributors may be used to endorse or promote products +' derived from this software without specific prior written permission. +' +' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +' === VBA-UTC Headers +#If Mac Then + +Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" (ByVal utc_Command As String, ByVal utc_Mode As String) As Long +Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" (ByVal utc_File As Long) As Long +Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long +Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" (ByVal utc_File As Long) As Long + +#ElseIf VBA7 Then + +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx +Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#Else + +Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#End If + +#If Mac Then + +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As Long +End Type + +#Else + +Private Type utc_SYSTEMTIME + utc_wYear As Integer + utc_wMonth As Integer + utc_wDayOfWeek As Integer + utc_wDay As Integer + utc_wHour As Integer + utc_wMinute As Integer + utc_wSecond As Integer + utc_wMilliseconds As Integer +End Type + +Private Type utc_TIME_ZONE_INFORMATION + utc_Bias As Long + utc_StandardName(0 To 31) As Integer + utc_StandardDate As utc_SYSTEMTIME + utc_StandardBias As Long + utc_DaylightName(0 To 31) As Integer + utc_DaylightDate As utc_SYSTEMTIME + utc_DaylightBias As Long +End Type + +#End If +' === End VBA-UTC + +#If Mac Then +#ElseIf VBA7 Then + +Private Declare PtrSafe Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ + (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long) + +#Else + +Private Declare Sub json_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ + (json_MemoryDestination As Any, json_MemorySource As Any, ByVal json_ByteLength As Long) + +#End If + +Private Type json_Options + ' VBA only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits + ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` + UseDoubleForLargeNumbers As Boolean + + ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys + AllowUnquotedKeys As Boolean + + ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson + EscapeSolidus As Boolean +End Type +Public JsonOptions As json_Options + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Convert JSON string to object (Dictionary/Collection) +' +' @method ParseJson +' @param {String} json_String +' @return {Object} (Dictionary or Collection) +' @throws 10001 - JSON parse error +'' +Public Function ParseJson(ByVal JsonString As String) As Object + Dim json_Index As Long + json_Index = 1 + + ' Remove vbCr, vbLf, and vbTab from json_String + JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") + + json_SkipSpaces JsonString, json_Index + Select Case VBA.Mid$(JsonString, json_Index, 1) + Case "{" + Set ParseJson = json_ParseObject(JsonString, json_Index) + Case "[" + Set ParseJson = json_ParseArray(JsonString, json_Index) + Case Else + ' Error: Invalid JSON string + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") + End Select +End Function + +'' +' Convert object (Dictionary/Collection/Array) to JSON +' +' @method ConvertToJson +' @param {Variant} JsonValue (Dictionary, Collection, or Array) +' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string +' @return {String} +'' +Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String + Dim json_buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + Dim json_Index As Long + Dim json_LBound As Long + Dim json_UBound As Long + Dim json_IsFirstItem As Boolean + Dim json_Index2D As Long + Dim json_LBound2D As Long + Dim json_UBound2D As Long + Dim json_IsFirstItem2D As Boolean + Dim json_Key As Variant + Dim json_Value As Variant + Dim json_DateStr As String + Dim json_Converted As String + Dim json_SkipItem As Boolean + Dim json_PrettyPrint As Boolean + Dim json_Indentation As String + Dim json_InnerIndentation As String + + json_LBound = -1 + json_UBound = -1 + json_IsFirstItem = True + json_LBound2D = -1 + json_UBound2D = -1 + json_IsFirstItem2D = True + json_PrettyPrint = Not IsMissing(Whitespace) + + Select Case VBA.VarType(JsonValue) + Case VBA.vbNull + ConvertToJson = "null" + Case VBA.vbDate + ' Date + json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) + + ConvertToJson = """" & json_DateStr & """" + Case VBA.vbString + ' String (or large number encoded as string) + If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then + ConvertToJson = JsonValue + Else + ConvertToJson = """" & json_Encode(JsonValue) & """" + End If + Case VBA.vbBoolean + If JsonValue Then + ConvertToJson = "true" + Else + ConvertToJson = "false" + End If + Case VBA.vbArray To VBA.vbArray + VBA.vbByte + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) + End If + End If + + ' Array + json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength + + On Error Resume Next + + json_LBound = LBound(JsonValue, 1) + json_UBound = UBound(JsonValue, 1) + json_LBound2D = LBound(JsonValue, 2) + json_UBound2D = UBound(JsonValue, 2) + + If json_LBound >= 0 And json_UBound >= 0 Then + For json_Index = json_LBound To json_UBound + If json_IsFirstItem Then + json_IsFirstItem = False + Else + ' Append comma to previous line + json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_LBound2D >= 0 And json_UBound2D >= 0 Then + ' 2D Array + If json_PrettyPrint Then + json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + json_BufferAppend json_buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength + + For json_Index2D = json_LBound2D To json_UBound2D + If json_IsFirstItem2D Then + json_IsFirstItem2D = False + Else + json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_InnerIndentation & json_Converted + End If + + json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Index2D + + If json_PrettyPrint Then + json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + + json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + json_IsFirstItem2D = True + Else + ' 1D Array + json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Index + End If + + On Error GoTo 0 + + If json_PrettyPrint Then + json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + + ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + + ' Dictionary or Collection + Case VBA.vbObject + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + End If + End If + + ' Dictionary + If VBA.TypeName(JsonValue) = "Dictionary" Then + json_BufferAppend json_buffer, "{", json_BufferPosition, json_BufferLength + For Each json_Key In JsonValue.Keys + ' For Objects, undefined (Empty/Nothing) is not added to object + json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) + If json_Converted = "" Then + json_SkipItem = json_IsUndefined(JsonValue(json_Key)) + Else + json_SkipItem = False + End If + + If Not json_SkipItem Then + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted + Else + json_Converted = """" & json_Key & """:" & json_Converted + End If + + json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Key + + If json_PrettyPrint Then + json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength + + ' Collection + ElseIf VBA.TypeName(JsonValue) = "Collection" Then + json_BufferAppend json_buffer, "[", json_BufferPosition, json_BufferLength + For Each json_Value In JsonValue + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(json_Value) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Value + + If json_PrettyPrint Then + json_BufferAppend json_buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + End If + + ConvertToJson = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal + ' Number (use decimals for numbers) + ConvertToJson = VBA.Replace(JsonValue, ",", ".") + Case Else + ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType + ' Use VBA's built-in to-string + On Error Resume Next + ConvertToJson = JsonValue + On Error GoTo 0 + End Select +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary + Dim json_Key As String + Dim json_NextChar As String + + Set json_ParseObject = New Dictionary + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "{" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "}" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_Key = json_ParseKey(json_String, json_Index) + json_NextChar = json_Peek(json_String, json_Index) + If json_NextChar = "[" Or json_NextChar = "{" Then + Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + Else + json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + End If + Loop + End If +End Function + +Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection + Set json_ParseArray = New Collection + + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "[" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "]" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_ParseArray.Add json_ParseValue(json_String, json_Index) + Loop + End If +End Function + +Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant + json_SkipSpaces json_String, json_Index + Select Case VBA.Mid$(json_String, json_Index, 1) + Case "{" + Set json_ParseValue = json_ParseObject(json_String, json_Index) + Case "[" + Set json_ParseValue = json_ParseArray(json_String, json_Index) + Case """", "'" + json_ParseValue = json_ParseString(json_String, json_Index) + Case Else + If VBA.Mid$(json_String, json_Index, 4) = "true" Then + json_ParseValue = True + json_Index = json_Index + 4 + ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then + json_ParseValue = False + json_Index = json_Index + 5 + ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then + json_ParseValue = Null + json_Index = json_Index + 4 + ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then + json_ParseValue = json_ParseNumber(json_String, json_Index) + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") + End If + End Select +End Function + +Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String + Dim json_Quote As String + Dim json_Char As String + Dim json_Code As String + Dim json_buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + json_SkipSpaces json_String, json_Index + + ' Store opening quote to look for matching closing quote + json_Quote = VBA.Mid$(json_String, json_Index, 1) + json_Index = json_Index + 1 + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case "\" + ' Escaped string, \\, or \/ + json_Index = json_Index + 1 + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case """", "\", "/", "'" + json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "b" + json_BufferAppend json_buffer, vbBack, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "f" + json_BufferAppend json_buffer, vbFormFeed, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "n" + json_BufferAppend json_buffer, vbCrLf, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "r" + json_BufferAppend json_buffer, vbCr, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "t" + json_BufferAppend json_buffer, vbTab, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "u" + ' Unicode character escape (e.g. \u00a9 = Copyright) + json_Index = json_Index + 1 + json_Code = VBA.Mid$(json_String, json_Index, 4) + json_BufferAppend json_buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength + json_Index = json_Index + 4 + End Select + Case json_Quote + json_ParseString = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) + json_Index = json_Index + 1 + Exit Function + Case Else + json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + End Select + Loop +End Function + +Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant + Dim json_Char As String + Dim json_Value As String + Dim json_IsLargeNumber As Boolean + + json_SkipSpaces json_String, json_Index + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + If VBA.InStr("+-0123456789.eE", json_Char) Then + ' Unlikely to have massive number, so use simple append rather than buffer here + json_Value = json_Value & json_Char + json_Index = json_Index + 1 + Else + ' Excel only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number + ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) + json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) + If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then + json_ParseNumber = json_Value + Else + ' VBA.Val does not use regional settings, so guard for comma is not needed + json_ParseNumber = VBA.Val(json_Value) + End If + Exit Function + End If + Loop +End Function + +Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String + ' Parse key with single or double quotes + If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then + json_ParseKey = json_ParseString(json_String, json_Index) + ElseIf JsonOptions.AllowUnquotedKeys Then + Dim json_Char As String + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + If (json_Char <> " ") And (json_Char <> ":") Then + json_ParseKey = json_ParseKey & json_Char + json_Index = json_Index + 1 + Else + Exit Do + End If + Loop + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") + End If + + ' Check for colon and skip if present or throw if not present + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> ":" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") + Else + json_Index = json_Index + 1 + End If +End Function + +Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean + ' Empty / Nothing -> undefined + Select Case VBA.VarType(json_Value) + Case VBA.vbEmpty + json_IsUndefined = True + Case VBA.vbObject + Select Case VBA.TypeName(json_Value) + Case "Empty", "Nothing" + json_IsUndefined = True + End Select + End Select +End Function + +Private Function json_Encode(ByVal json_Text As Variant) As String + ' Reference: http://www.ietf.org/rfc/rfc4627.txt + ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab + Dim json_Index As Long + Dim json_Char As String + Dim json_AscCode As Long + Dim json_buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + For json_Index = 1 To VBA.Len(json_Text) + json_Char = VBA.Mid$(json_Text, json_Index, 1) + json_AscCode = VBA.AscW(json_Char) + + ' When AscW returns a negative number, it returns the twos complement form of that number. + ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. + ' https://support.microsoft.com/en-us/kb/272138 + If json_AscCode < 0 Then + json_AscCode = json_AscCode + 65536 + End If + + ' From spec, ", \, and control characters must be escaped (solidus is optional) + + Select Case json_AscCode + Case 34 + ' " -> 34 -> \" + json_Char = "\""" + Case 92 + ' \ -> 92 -> \\ + json_Char = "\\" + Case 47 + ' / -> 47 -> \/ (optional) + If JsonOptions.EscapeSolidus Then + json_Char = "\/" + End If + Case 8 + ' backspace -> 8 -> \b + json_Char = "\b" + Case 12 + ' form feed -> 12 -> \f + json_Char = "\f" + Case 10 + ' line feed -> 10 -> \n + json_Char = "\n" + Case 13 + ' carriage return -> 13 -> \r + json_Char = "\r" + Case 9 + ' tab -> 9 -> \t + json_Char = "\t" + Case 0 To 31, 127 To 65535 + ' Non-ascii characters -> convert to 4-digit hex + json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) + End Select + + json_BufferAppend json_buffer, json_Char, json_BufferPosition, json_BufferLength + Next json_Index + + json_Encode = json_BufferToString(json_buffer, json_BufferPosition, json_BufferLength) +End Function + +Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String + ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) + json_SkipSpaces json_String, json_Index + json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) +End Function + +Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) + ' Increment index to skip over spaces + Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " + json_Index = json_Index + 1 + Loop +End Sub + +Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean + ' Check if the given string is considered a "large number" + ' (See json_ParseNumber) + + Dim json_Length As Long + Dim json_CharIndex As Long + json_Length = VBA.Len(json_String) + + ' Length with be at least 16 characters and assume will be less than 100 characters + If json_Length >= 16 And json_Length <= 100 Then + Dim json_CharCode As String + Dim json_Index As Long + + json_StringIsLargeNumber = True + + For json_CharIndex = 1 To json_Length + json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) + Select Case json_CharCode + ' Look for .|0-9|E|e + Case 46, 48 To 57, 69, 101 + ' Continue through characters + Case Else + json_StringIsLargeNumber = False + Exit Function + End Select + Next json_CharIndex + End If +End Function + +Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, errorMessage As String) + ' Provide detailed parse error message, including details of where and what occurred + ' + ' Example: + ' Error parsing JSON: + ' {"abcde":True} + ' ^ + ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' + + Dim json_StartIndex As Long + Dim json_StopIndex As Long + + ' Include 10 characters before and after error (if possible) + json_StartIndex = json_Index - 10 + json_StopIndex = json_Index + 10 + If json_StartIndex <= 0 Then + json_StartIndex = 1 + End If + If json_StopIndex > VBA.Len(json_String) Then + json_StopIndex = VBA.Len(json_String) + End If + + json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ + VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ + VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ + errorMessage +End Function + +Private Sub json_BufferAppend(ByRef json_buffer As String, _ + ByRef json_Append As Variant, _ + ByRef json_BufferPosition As Long, _ + ByRef json_BufferLength As Long) +#If Mac Then + json_buffer = json_buffer & json_Append +#Else + ' VBA can be slow to append strings due to allocating a new string for each append + ' Instead of using the traditional append, allocate a large empty string and then copy string at append position + ' + ' Example: + ' Buffer: "abc " + ' Append: "def" + ' Buffer Position: 3 + ' Buffer Length: 5 + ' + ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer + ' Buffer: "abc " + ' Buffer Length: 10 + ' + ' Copy memory for "def" into buffer at position 3 (0-based) + ' Buffer: "abcdef " + ' + ' Approach based on cStringBuilder from vbAccelerator + ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.LenB(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunks until buffer is long enough + Dim json_TemporaryLength As Long + + json_TemporaryLength = json_BufferLength + Do While json_TemporaryLength < json_LengthPlusPosition + ' Initially, initialize string with 255 characters, + ' then add large chunks (8192) after that + ' + ' Size: # Characters x 2 bytes / character + If json_TemporaryLength = 0 Then + json_TemporaryLength = json_TemporaryLength + 510 + Else + json_TemporaryLength = json_TemporaryLength + 16384 + End If + Loop + + json_buffer = json_buffer & VBA.Space$((json_TemporaryLength - json_BufferLength) \ 2) + json_BufferLength = json_TemporaryLength + End If + + ' Copy memory from append to buffer at buffer position + json_CopyMemory ByVal json_UnsignedAdd(StrPtr(json_buffer), _ + json_BufferPosition), _ + ByVal StrPtr(json_Append), _ + json_AppendLength + + json_BufferPosition = json_BufferPosition + json_AppendLength +#End If +End Sub + +Private Function json_BufferToString(ByRef json_buffer As String, ByVal json_BufferPosition As Long, ByVal json_BufferLength As Long) As String +#If Mac Then + json_BufferToString = json_buffer +#Else + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_buffer, json_BufferPosition \ 2) + End If +#End If +End Function + +#If VBA7 Then +Private Function json_UnsignedAdd(json_Start As LongPtr, json_Increment As Long) As LongPtr +#Else +Private Function json_UnsignedAdd(json_Start As Long, json_Increment As Long) As Long +#End If + + If json_Start And &H80000000 Then + json_UnsignedAdd = json_Start + json_Increment + ElseIf (json_Start Or &H80000000) < -json_Increment Then + json_UnsignedAdd = json_Start + json_Increment + Else + json_UnsignedAdd = (json_Start + &H80000000) + (json_Increment + &H80000000) + End If +End Function + +'' +' VBA-UTC v1.0.2 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter +' +' UTC/ISO 8601 Converter for VBA +' +' Errors: +' 10011 - UTC parsing error +' 10012 - UTC conversion error +' 10013 - ISO 8601 parsing error +' 10014 - ISO 8601 conversion error +' +' @module UtcConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +' (Declarations moved to top) + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Parse UTC date to local date +' +' @method ParseUtc +' @param {Date} UtcDate +' @return {Date} Local date +' @throws 10011 - UTC parsing error +'' +Public Function ParseUtc(utc_UtcDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ParseUtc = utc_ConvertDate(utc_UtcDate) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_LocalDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate + + ParseUtc = utc_SystemTimeToDate(utc_LocalDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to UTC date +' +' @method ConvertToUrc +' @param {Date} utc_LocalDate +' @return {Date} UTC date +' @throws 10012 - UTC conversion error +'' +Public Function ConvertToUtc(utc_LocalDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_UtcDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate + + ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Parse ISO 8601 date string to local date +' +' @method ParseIso +' @param {Date} utc_IsoString +' @return {Date} Local date +' @throws 10013 - ISO 8601 parsing error +'' +Public Function ParseIso(utc_IsoString As String) As Date + On Error GoTo utc_ErrorHandling + + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + Dim utc_OffsetIndex As Long + Dim utc_HasOffset As Boolean + Dim utc_NegativeOffset As Boolean + Dim utc_OffsetParts() As String + Dim utc_Offset As Date + + utc_Parts = VBA.Split(utc_IsoString, "T") + utc_DateParts = VBA.Split(utc_Parts(0), "-") + ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) + + If UBound(utc_Parts) > 0 Then + If VBA.InStr(utc_Parts(1), "Z") Then + utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") + Else + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") + If utc_OffsetIndex = 0 Then + utc_NegativeOffset = True + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") + End If + + If utc_OffsetIndex > 0 Then + utc_HasOffset = True + utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") + utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") + + Select Case UBound(utc_OffsetParts) + Case 0 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) + Case 1 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) + End Select + + If utc_NegativeOffset Then: utc_Offset = -utc_Offset + Else + utc_TimeParts = VBA.Split(utc_Parts(1), ":") + End If + End If + + Select Case UBound(utc_TimeParts) + Case 0 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) + Case 1 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) + End Select + + ParseIso = ParseUtc(ParseIso) + + If utc_HasOffset Then + ParseIso = ParseIso + utc_Offset + End If + End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to ISO 8601 string +' +' @method ConvertToIso +' @param {Date} utc_LocalDate +' @return {Date} ISO 8601 string +' @throws 10014 - ISO 8601 conversion error +'' +Public Function ConvertToIso(utc_LocalDate As Date) As String + On Error GoTo utc_ErrorHandling + + ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") + + Exit Function + +utc_ErrorHandling: + Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +#If Mac Then + +Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date + Dim utc_ShellCommand As String + Dim utc_Result As utc_ShellResult + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + + If utc_ConvertToUtc Then + utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ + " +'%s'` +'%Y-%m-%d %H:%M:%S'" + Else + utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ + "+'%Y-%m-%d %H:%M:%S'" + End If + + utc_Result = utc_ExecuteInShell(utc_ShellCommand) + + If utc_Result.utc_Output = "" Then + Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" + Else + utc_Parts = Split(utc_Result.utc_Output, " ") + utc_DateParts = Split(utc_Parts(0), "-") + utc_TimeParts = Split(utc_Parts(1), ":") + + utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ + TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) + End If +End Function + +Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult + Dim utc_File As Long + Dim utc_Chunk As String + Dim utc_Read As Long + + On Error GoTo utc_ErrorHandling + utc_File = utc_popen(utc_ShellCommand, "r") + + If utc_File = 0 Then: Exit Function + + Do While utc_feof(utc_File) = 0 + utc_Chunk = VBA.Space$(50) + utc_Read = utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File) + If utc_Read > 0 Then + utc_Chunk = VBA.Left$(utc_Chunk, utc_Read) + utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk + End If + Loop + +utc_ErrorHandling: + utc_ExecuteInShell.utc_ExitCode = utc_pclose(utc_File) +End Function + +#Else + +Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME + utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) + utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) + utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) + utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) + utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) + utc_DateToSystemTime.utc_wSecond = VBA.second(utc_Value) + utc_DateToSystemTime.utc_wMilliseconds = 0 +End Function + +Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date + utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ + TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) +End Function + +#End If diff --git a/src/vbaDeveloper.xlam/XMLexporter.bas b/src/vbaDeveloper.xlam/XMLexporter.bas index 353d975..57eec58 100644 --- a/src/vbaDeveloper.xlam/XMLexporter.bas +++ b/src/vbaDeveloper.xlam/XMLexporter.bas @@ -122,7 +122,7 @@ Public Sub rebuildXML(destinationFolder As String, containingFolderName As Strin 'Set what some items should be named Dim fileExtension As String, strDate As String, fileShortName As String, fileName As String, zipFileName As String - strDate = VBA.format(Now, " yyyy-mm-dd hh-mm-ss") + strDate = VBA.Format(Now, " yyyy-mm-dd hh-mm-ss") fileExtension = "." & Right(containingFolderName, Len(containingFolderName) - InStrRev(containingFolderName, ".")) 'The containing folder is the folder that is under \src and that is named the same thing as the target file (folder is filename.xlsx) - can parse file ending out of folder fileShortName = Right(containingFolderName, Len(containingFolderName) - InStrRev(containingFolderName, "\")) 'This should be just the final folder name fileShortName = Left(fileShortName, Len(fileShortName) - (Len(fileShortName) - InStr(fileShortName, ".")) - 1) 'remove the extension, since we've saved that separately. From 3a788c70eb8f68c27068866e19b2f847a0b7bb51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20K=C3=BCnzli?= Date: Mon, 13 Feb 2017 16:47:37 +0100 Subject: [PATCH 6/6] bugfix: double import of every component --- src/vbaDeveloper.xlam/Build.bas | 1 - 1 file changed, 1 deletion(-) diff --git a/src/vbaDeveloper.xlam/Build.bas b/src/vbaDeveloper.xlam/Build.bas index 559dc04..f03e779 100644 --- a/src/vbaDeveloper.xlam/Build.bas +++ b/src/vbaDeveloper.xlam/Build.bas @@ -292,7 +292,6 @@ End Sub ' Assumes any component with same name has already been removed. Private Sub importComponent(vbaProject As VBProject, filePath As String) Debug.Print "Importing component from " & filePath - vbaProject.VBComponents.Import filePath Dim newComp As VBComponent Set newComp = vbaProject.VBComponents.Import(filePath) Do While Trim(newComp.codeModule.lines(1, 1)) = "" And newComp.codeModule.CountOfLines > 1