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 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 ab69abd..f03e779 100644 --- a/src/vbaDeveloper.xlam/Build.bas +++ b/src/vbaDeveloper.xlam/Build.bas @@ -1,369 +1,371 @@ -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, True +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 + BuildForm.exportMSForm export_path, component + 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 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. + 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 + 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 + + +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/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/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/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/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..d09b772 100644 --- a/src/vbaDeveloper.xlam/EventListener.cls +++ b/src/vbaDeveloper.xlam/EventListener.cls @@ -1,70 +1,71 @@ -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/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 fa74e01..a805ac6 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/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/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..57eec58 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