diff --git a/Testing/Testing.accdb.src/vcs-options.json b/Testing/Testing.accdb.src/vcs-options.json index f01eb3e0..5c35fb53 100644 --- a/Testing/Testing.accdb.src/vcs-options.json +++ b/Testing/Testing.accdb.src/vcs-options.json @@ -1,6 +1,6 @@ { "Info": { - "AddinVersion": "4.0.28", + "AddinVersion": "4.0.30", "AccessVersion": "14.0 32-bit" }, "Options": { diff --git a/Version Control.accda.src/dbs-properties.json b/Version Control.accda.src/dbs-properties.json index 7c5bec05..0bbc44a6 100644 --- a/Version Control.accda.src/dbs-properties.json +++ b/Version Control.accda.src/dbs-properties.json @@ -41,7 +41,7 @@ "Type": 10 }, "AppVersion": { - "Value": "4.0.30", + "Value": "4.0.31", "Type": 10 }, "Auto Compact": { diff --git a/Version Control.accda.src/forms/frmVCSConflict.bas b/Version Control.accda.src/forms/frmVCSConflict.bas index ed450a15..2fdb8b5d 100644 --- a/Version Control.accda.src/forms/frmVCSConflict.bas +++ b/Version Control.accda.src/forms/frmVCSConflict.bas @@ -860,151 +860,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Compare Database -Option Explicit - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdCancel_Click -' Author : Adam Waller -' Date : 2/4/2021 -' Purpose : Close form if user presses the escape key. (Cancel property = True) -'--------------------------------------------------------------------------------------- -' -Private Sub cmdCancel_Click() - DoCmd.Close acForm, Me.Name -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdContinue_Click -' Author : Adam Waller -' Date : 5/27/2021 -' Purpose : User selected to continue. Close and process conflicts. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdContinue_Click() - - Dim lngRemaining As Long - - lngRemaining = ActionDecisionsNeeded - If lngRemaining > 0 Then - MsgBox2 "Please Resolve Conflicts", _ - lngRemaining & " item(s) need to be resolved to continue.", _ - "You can cancel this operation if you need to do further review.", vbInformation - Else - VCSIndex.Conflicts.ApproveResolutions = True - DoCmd.Close acForm, Me.Name - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Load -' Author : Adam Waller -' Date : 4/15/2020 -' Purpose : Setting the control source causes delayed display. This way the display -' : is instant when the form is opened. -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Load() - ' Display version (better performance than bound control) - lblVersion.Caption = Replace(lblVersion.Caption, "${version}", GetVCSVersion()) - - Dim frmList As Form_frmVCSConflictList - Set frmList = Me.sfrmConflictList.Form - - ' Update heading caption - If Log.OperationType = eotExport Then - lblHeading.Caption = "These source files have changed since the last export" - With frmList.cboResolution - .AddItem eResolveConflict.ercSkip & ";" & "Skip" - .AddItem eResolveConflict.ercOverwrite & ";" & "Overwrite source file" - End With - Else - lblHeading.Caption = "These database objects have changed since the last export" - With frmList.cboResolution - .AddItem eResolveConflict.ercSkip & ";" & "Skip" - .AddItem eResolveConflict.ercOverwrite & ";" & "Overwrite database object" - End With - End If - - ' Change to resizable form - MakeDialogResizable Me - - ' Set initial column size - DoEvents - Form_Resize - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Resize -' Author : Adam Waller -' Date : 5/16/2023 -' Purpose : Adjust column widths on subform. -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Resize() - ScaleColumns Me.sfrmConflictList.Form, , _ - Array("txtObjectDate", "txtFileDate", "txtDiff") -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdOverwriteAll_Click -' Author : Adam Waller -' Date : 11/1/2021 -' Purpose : Overwrite all items in the list -'--------------------------------------------------------------------------------------- -' -Private Sub cmdOverwriteAll_Click() - sfrmConflictList.SetFocus - CodeDb.Execute "update tblConflicts set Resolution=" & eResolveConflict.ercOverwrite, dbFailOnError - sfrmConflictList.Requery -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdSkipAll_Click -' Author : Adam Waller -' Date : 11/1/2021 -' Purpose : Skip all items in the list -'--------------------------------------------------------------------------------------- -' -Private Sub cmdSkipAll_Click() - sfrmConflictList.SetFocus - CodeDb.Execute "update tblConflicts set Resolution=" & eResolveConflict.ercSkip, dbFailOnError - sfrmConflictList.Requery -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : NeedsActionDecision -' Author : Adam Waller -' Date : 2/22/2023 -' Purpose : Count how many records need a decision before we can continue. -'--------------------------------------------------------------------------------------- -' -Private Function ActionDecisionsNeeded() As Long - - Dim dbs As DAO.Database - Dim rst As DAO.Recordset - - Set dbs = CodeDb - Set rst = dbs.OpenRecordset( _ - "select count(*) as Remaining from (select id from tblConflicts where NZ(Resolution)=0)", _ - dbOpenDynaset, dbOpenForwardOnly, dbReadOnly) - - ActionDecisionsNeeded = Nz(rst!Remaining) - rst.Close - Set rst = Nothing - Set dbs = Nothing - -End Function +' See "frmVCSConflict.cls" diff --git a/Version Control.accda.src/forms/frmVCSConflict.cls b/Version Control.accda.src/forms/frmVCSConflict.cls new file mode 100644 index 00000000..931092db --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSConflict.cls @@ -0,0 +1,148 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdCancel_Click +' Author : Adam Waller +' Date : 2/4/2021 +' Purpose : Close form if user presses the escape key. (Cancel property = True) +'--------------------------------------------------------------------------------------- +' +Private Sub cmdCancel_Click() + DoCmd.Close acForm, Me.Name +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdContinue_Click +' Author : Adam Waller +' Date : 5/27/2021 +' Purpose : User selected to continue. Close and process conflicts. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdContinue_Click() + + Dim lngRemaining As Long + + lngRemaining = ActionDecisionsNeeded + If lngRemaining > 0 Then + MsgBox2 "Please Resolve Conflicts", _ + lngRemaining & " item(s) need to be resolved to continue.", _ + "You can cancel this operation if you need to do further review.", vbInformation + Else + VCSIndex.Conflicts.ApproveResolutions = True + DoCmd.Close acForm, Me.Name + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Load +' Author : Adam Waller +' Date : 4/15/2020 +' Purpose : Setting the control source causes delayed display. This way the display +' : is instant when the form is opened. +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Load() + ' Display version (better performance than bound control) + lblVersion.Caption = Replace(lblVersion.Caption, "${version}", GetVCSVersion()) + + Dim frmList As Form_frmVCSConflictList + Set frmList = Me.sfrmConflictList.Form + + ' Update heading caption + If Log.OperationType = eotExport Then + lblHeading.Caption = "These source files have changed since the last export" + With frmList.cboResolution + .AddItem eResolveConflict.ercSkip & ";" & "Skip" + .AddItem eResolveConflict.ercOverwrite & ";" & "Overwrite source file" + End With + Else + lblHeading.Caption = "These database objects have changed since the last export" + With frmList.cboResolution + .AddItem eResolveConflict.ercSkip & ";" & "Skip" + .AddItem eResolveConflict.ercOverwrite & ";" & "Overwrite database object" + End With + End If + + ' Change to resizable form + MakeDialogResizable Me + + ' Set initial column size + DoEvents + Form_Resize + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Resize +' Author : Adam Waller +' Date : 5/16/2023 +' Purpose : Adjust column widths on subform. +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Resize() + ScaleColumns Me.sfrmConflictList.Form, , _ + Array("txtObjectDate", "txtFileDate", "txtDiff") +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdOverwriteAll_Click +' Author : Adam Waller +' Date : 11/1/2021 +' Purpose : Overwrite all items in the list +'--------------------------------------------------------------------------------------- +' +Private Sub cmdOverwriteAll_Click() + sfrmConflictList.SetFocus + CodeDb.Execute "update tblConflicts set Resolution=" & eResolveConflict.ercOverwrite, dbFailOnError + sfrmConflictList.Requery +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdSkipAll_Click +' Author : Adam Waller +' Date : 11/1/2021 +' Purpose : Skip all items in the list +'--------------------------------------------------------------------------------------- +' +Private Sub cmdSkipAll_Click() + sfrmConflictList.SetFocus + CodeDb.Execute "update tblConflicts set Resolution=" & eResolveConflict.ercSkip, dbFailOnError + sfrmConflictList.Requery +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : NeedsActionDecision +' Author : Adam Waller +' Date : 2/22/2023 +' Purpose : Count how many records need a decision before we can continue. +'--------------------------------------------------------------------------------------- +' +Private Function ActionDecisionsNeeded() As Long + + Dim dbs As DAO.Database + Dim rst As DAO.Recordset + + Set dbs = CodeDb + Set rst = dbs.OpenRecordset( _ + "select count(*) as Remaining from (select id from tblConflicts where NZ(Resolution)=0)", _ + dbOpenDynaset, dbOpenForwardOnly, dbReadOnly) + + ActionDecisionsNeeded = Nz(rst!Remaining) + rst.Close + Set rst = Nothing + Set dbs = Nothing + +End Function diff --git a/Version Control.accda.src/forms/frmVCSConflictList.bas b/Version Control.accda.src/forms/frmVCSConflictList.bas index b5189e50..be68c9ba 100644 --- a/Version Control.accda.src/forms/frmVCSConflictList.bas +++ b/Version Control.accda.src/forms/frmVCSConflictList.bas @@ -452,90 +452,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Compare Database -Option Explicit - - -'--------------------------------------------------------------------------------------- -' Procedure : txtDiff_Click -' Author : Adam Waller -' Date : 5/27/2021 -' Purpose : Launch diff program to review changes. -' : Note that the changed file is not always the primary source file. -'--------------------------------------------------------------------------------------- -' -Private Sub txtDiff_Click() - - Dim strTempFile As String - Dim strSourceFile As String - Dim strFileName As String - Dim cCont As IDbComponent - Dim dItems As Dictionary - Dim cItem As IDbComponent - - ' Move focus back to resolution control - cboResolution.SetFocus - DoEvents - - ' Make sure we have a valid tool defined - If Not (modObjects.Diff.HasValidCompareTool) Then - MsgBox2 "No Compare Tool Defined", _ - "Please specify a compare tool (i.e. WinMerge, VSCode) in the add-in options.", , vbExclamation - Exit Sub - End If - - ' Make sure we have a file name to compare - strFileName = Nz(txtFileName) - If strFileName = vbNullString Then - MsgBox2 "File name not found", "A file name is required to compare source files.", , vbExclamation - Else - ' Build full path to source file - strSourceFile = Options.GetExportFolder & strFileName - - ' Check for existing temp file - strTempFile = VCSIndex.GetTempExportFolder & strFileName - If Not FSO.FileExists(strTempFile) Then - - ' Has not already been exported. Export a copy that we can use for the compare. - ' Try to find matching category and file - For Each cCont In GetContainers(ecfAllObjects) - If cCont.Category = Nz(txtComponent) Then - Set dItems = cCont.GetAllFromDB(False) - If cCont.SingleFile Then - Set cItem = cCont - Else - If dItems.Exists(strFileName) Then - Set cItem = dItems(strFileName) - End If - End If - ' Build new export file name and export - If Not cItem Is Nothing Then cItem.Export strTempFile - Exit For - End If - Next cCont - End If - - ' Show comparison if we were able to export a temp file - If Not FSO.FileExists(strTempFile) Then - MsgBox2 "Unable to Diff Object", "Unable to produce a temporary diff file with the current database object.", , vbExclamation - Else - If Not FSO.FileExists(strSourceFile) Then - MsgBox2 "Source File Not Found", "Could not find the source file needed to diff this object:", strSourceFile, vbExclamation - Else - ' Now that we have both files, diff the files for the user - If Log.OperationType = eotExport Then - ' Show the database object as the modified version - modObjects.Diff.Files strSourceFile, strTempFile - Else - ' Show the source file as the modified version - modObjects.Diff.Files strTempFile, strSourceFile - End If - End If - End If - End If - -End Sub +' See "frmVCSConflictList.cls" \ No newline at end of file diff --git a/Version Control.accda.src/forms/frmVCSConflictList.cls b/Version Control.accda.src/forms/frmVCSConflictList.cls new file mode 100644 index 00000000..4d231b42 --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSConflictList.cls @@ -0,0 +1,87 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + + +'--------------------------------------------------------------------------------------- +' Procedure : txtDiff_Click +' Author : Adam Waller +' Date : 5/27/2021 +' Purpose : Launch diff program to review changes. +' : Note that the changed file is not always the primary source file. +'--------------------------------------------------------------------------------------- +' +Private Sub txtDiff_Click() + + Dim strTempFile As String + Dim strSourceFile As String + Dim strFileName As String + Dim cCont As IDbComponent + Dim dItems As Dictionary + Dim cItem As IDbComponent + + ' Move focus back to resolution control + cboResolution.SetFocus + DoEvents + + ' Make sure we have a valid tool defined + If Not (modObjects.Diff.HasValidCompareTool) Then + MsgBox2 "No Compare Tool Defined", _ + "Please specify a compare tool (i.e. WinMerge, VSCode) in the add-in options.", , vbExclamation + Exit Sub + End If + + ' Make sure we have a file name to compare + strFileName = Nz(txtFileName) + If strFileName = vbNullString Then + MsgBox2 "File name not found", "A file name is required to compare source files.", , vbExclamation + Else + ' Build full path to source file + strSourceFile = Options.GetExportFolder & strFileName + + ' Check for existing temp file + strTempFile = VCSIndex.GetTempExportFolder & strFileName + If Not FSO.FileExists(strTempFile) Then + + ' Has not already been exported. Export a copy that we can use for the compare. + ' Try to find matching category and file + For Each cCont In GetContainers(ecfAllObjects) + If cCont.Category = Nz(txtComponent) Then + Set dItems = cCont.GetAllFromDB(False) + If cCont.SingleFile Then + Set cItem = cCont + Else + If dItems.Exists(strFileName) Then + Set cItem = dItems(strFileName) + End If + End If + ' Build new export file name and export + If Not cItem Is Nothing Then cItem.Export strTempFile + Exit For + End If + Next cCont + End If + + ' Show comparison if we were able to export a temp file + If Not FSO.FileExists(strTempFile) Then + MsgBox2 "Unable to Diff Object", "Unable to produce a temporary diff file with the current database object.", , vbExclamation + Else + If Not FSO.FileExists(strSourceFile) Then + MsgBox2 "Source File Not Found", "Could not find the source file needed to diff this object:", strSourceFile, vbExclamation + Else + ' Now that we have both files, diff the files for the user + If Log.OperationType = eotExport Then + ' Show the database object as the modified version + modObjects.Diff.Files strSourceFile, strTempFile + Else + ' Show the source file as the modified version + modObjects.Diff.Files strTempFile, strSourceFile + End If + End If + End If + End If + +End Sub diff --git a/Version Control.accda.src/forms/frmVCSDatabase.bas b/Version Control.accda.src/forms/frmVCSDatabase.bas index d854e89a..84f90842 100644 --- a/Version Control.accda.src/forms/frmVCSDatabase.bas +++ b/Version Control.accda.src/forms/frmVCSDatabase.bas @@ -16,10 +16,10 @@ Begin Form Width =10800 DatasheetFontHeight =11 ItemSuffix =263 - Left =20761 - Top =2250 - Right =-29055 - Bottom =13995 + Left =3225 + Top =2430 + Right =18945 + Bottom =14175 RecSrcDt = Begin 0x79e78b777268e540 End @@ -867,387 +867,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Compare Database -Option Explicit - - -' Store original name, just in case we rename an existing entry. -Private m_strOriginalName As String - - -'--------------------------------------------------------------------------------------- -' Procedure : LoadSchema -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Load a schema by name -'--------------------------------------------------------------------------------------- -' -Public Sub LoadSchema(strName As String, dSchema As Dictionary) - - Dim dParams As Dictionary - - ' Merge values into defaults to ensure that all values are defined - Set dParams = GetDefaults - MergeDictionary dParams, dSchema - MergeDotEnv strName, dParams - - ' Save original name, just in case it is renamed - m_strOriginalName = strName - - ' Load values from dictionary parameters - txtName = strName - chkEnabled = dParams("Enabled") - cboType = dParams("DatabaseType") - chkUtcDates = dParams("UtcDateTime") - txtDescription = dParams("Description") - txtFilter = dParams("Filter") - cboConnect = dParams("Connect") - chkSaveDotEnv = dParams("UseDotEnv") - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : MergeDotEnv -' Author : Adam Waller -' Date : 7/31/2023 -' Purpose : Merge any specified .env params into dictionary. (Will override schema -' : options saved in vcs-options.json) -'--------------------------------------------------------------------------------------- -' -Private Sub MergeDotEnv(strSchemaName As String, ByRef dParams As Dictionary) - Dim strFile As String - strFile = BuildPath2(Options.GetExportFolder & "databases", GetSafeFileName(strSchemaName), ".env") - If FSO.FileExists(strFile) Then - With New clsDotEnv - .LoadFromFile strFile - .MergeIntoDictionary dParams, False - End With - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : SaveConnectionString -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Saves the connection string to a .env file. -'--------------------------------------------------------------------------------------- -' -Private Sub SaveConnectionStringToFile() - - Dim strFile As String - - ' Guard clause safety check - If Nz(txtName) = vbNullString Or Nz(cboConnect) = vbNullString Then Exit Sub - - ' Update the value in the .env file. (Creating the file, if needed.) - strFile = BuildPath2(Options.GetExportFolder & "databases", GetSafeFileName(Nz(txtName)), ".env") - With New clsDotEnv - ' Reload file so we preserve existing values - .LoadFromFile strFile - .SetVar "CONNECT", Nz(cboConnect) - .SaveToFile strFile - End With - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdCancel_Click -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Close this form -'--------------------------------------------------------------------------------------- -' -Private Sub cmdCancel_Click() - DoCmd.Close acForm, Me.Name -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdExamples_Click -' Author : Adam Waller -' Date : 8/2/2023 -' Purpose : Show syntax examples on the Wiki -'--------------------------------------------------------------------------------------- -' -Private Sub cmdExamples_Click() - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdSaveAndClose_Click -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Save the schema back to the options form. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdSaveAndClose_Click() - If SaveConnection Then - Form_frmVCSOptions.RefreshSchemaList - DoCmd.Close acForm, Me.Name - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : SaveConnection -' Author : Adam Waller -' Date : 7/21/2023 -' Purpose : Save the current connection, return true if successful. -'--------------------------------------------------------------------------------------- -' -Private Function SaveConnection() As Boolean - - Dim dSchema As Dictionary - Dim strKey As String - - If Not PassedValidation Then Exit Function - - If IsLoaded(acForm, "frmVCSOptions") Then - With Form_frmVCSOptions - - ' Make sure we have a dictionary object - If .DatabaseSchemas Is Nothing Then Set .DatabaseSchemas = New Dictionary - - ' Save to options form - With .DatabaseSchemas - - ' Get a reference to dictionary object - strKey = Nz(txtName) - If Not .Exists(strKey) Then - ' Could be a rename - Set dSchema = New Dictionary - .Add strKey, dSchema - ' Remove any previous entry - If Len(m_strOriginalName) Then - If .Exists(m_strOriginalName) Then .Remove m_strOriginalName - End If - End If - - ' Load form values - SetParamsFromForm .Item(strKey) - - ' Connection string - If chkSaveDotEnv Then - CheckGitignoreDotEnv - ' Save connection string to .env file - SaveConnectionStringToFile - ' Remove connect parameter from dictionary - If .Item(strKey).Exists("Connect") Then .Item(strKey).Remove "Connect" - End If - End With - End With - - ' Return success - SaveConnection = True - Else - MsgBox2 "Options form not found", "The Options form must be open to save changes to external database connections", , vbExclamation - End If - -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : SetParamsFromForm -' Author : Adam Waller -' Date : 7/31/2023 -' Purpose : Sets the dictionary parameters based on the current form values. -' : (This is especially helpful for testing filters before saving an entry.) -'--------------------------------------------------------------------------------------- -' -Private Sub SetParamsFromForm(ByRef dParams As Dictionary) - With dParams - .Item("Enabled") = CBool(chkEnabled) - .Item("DatabaseType") = CInt(cboType) - .Item("Description") = Nz(txtDescription) - .Item("Filter") = Nz(txtFilter) - .Item("UtcDateTime") = CBool(chkUtcDates) - .Item("Connect") = Nz(cboConnect) - .Item("UseDotEnv") = CBool(chkSaveDotEnv) - End With -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : GetDefaults -' Author : Adam Waller -' Date : 7/31/2023 -' Purpose : Set the default values for connection parameters -'--------------------------------------------------------------------------------------- -' -Private Function GetDefaults() As Dictionary - Set GetDefaults = New Dictionary - With GetDefaults - .CompareMode = TextCompare - .Item("Enabled") = True - .Item("DatabaseType") = 1 - .Item("Description") = vbNullString - .Item("Filter") = vbNullString - .Item("UtcDateTime") = False - .Item("Connect") = vbNullString - .Item("UseDotEnv") = True - End With -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : PassedValidation -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Return true if we pass validation on the form to save the entry. -'--------------------------------------------------------------------------------------- -' -Private Function PassedValidation() As Boolean - - Dim strMsg As String - - ' TODO: Could add more validation for filter entries - - If Len(Nz(cboConnect)) < 5 Then strMsg = "Please select or enter a connection string for database" - If Nz(cboType, -1) < 0 Then strMsg = "Please select database type" - If Len(Nz(txtName)) = 0 Then strMsg = "Connection name is required" - - If Len(strMsg) Then - MsgBox2 "Please fix validation issues to continue", strMsg, "See online wiki for additional documentation", vbExclamation - Else - PassedValidation = True - End If - -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdTest_Click -' Author : Adam Waller -' Date : 7/21/2023 -' Purpose : Test the current filter and return the number of objects found. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdTest_Click() - - Dim cSchema As IDbSchema - Dim lngCount As Long - Dim dblStart As Double - Dim dParams As Dictionary - - txtFilter.SetFocus - txtFilter.SelStart = 9999 - If Not PassedValidation Then Exit Sub - - Select Case cboType - Case eDatabaseServerType.estMsSql - Set cSchema = New clsSchemaMsSql - Case eDatabaseServerType.estMySql - Set cSchema = New clsSchemaMySql - End Select - - ' Retrieve object count from server. - If Not cSchema Is Nothing Then - Set dParams = New Dictionary - dParams.CompareMode = TextCompare - SetParamsFromForm dParams - cSchema.Initialize dParams - dblStart = Perf.MicroTimer - DoCmd.Hourglass True - lngCount = cSchema.ObjectCount(False) - DoCmd.Hourglass False - MsgBox2 lngCount & " Objects Found", "A total of " & lngCount & " database objects were retrieved in " & _ - Round(Perf.MicroTimer - dblStart, 2) & " seconds.", , vbInformation - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : CheckGitignoreDotEnv -' Author : Adam Waller -' Date : 7/31/2023 -' Purpose : If the project appears to be a .git repository, check to see if .env -' : appears in the .gitignore file. -' : (This is not a comprehensive test, but just an extra aid for most common -' : scenarios to help users avoid inadvertently comitting a .env file to -' : their version control system.) -'--------------------------------------------------------------------------------------- -' -Private Sub CheckGitignoreDotEnv() - - Dim strPath As String - Dim strContent As String - - ' Guess at the standard location for a .gitignore file - strPath = Options.GetExportFolder & "..\.gitignore" - If FSO.FileExists(strPath) Then - strContent = ReadFile(strPath) - If Len(strContent) Then - If InStr(1, strContent, ".env", vbTextCompare) = 0 Then - MsgBox2 "Potentially Sensitive File", _ - "Please note: .env files should not be committed to version control.", _ - "To avoid exposing credentials to your repository, please exclude .env files in .gitignore", _ - vbExclamation - End If - End If - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Load -' Author : Adam Waller -' Date : 8/1/2023 -' Purpose : Load in sample connection strings from the current database. -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Load() - LoadSampleConnectionStrings -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : LoadSampleConnectionStrings -' Author : Adam Waller -' Date : 8/1/2023 -' Purpose : Loads in some sample connection strings from the current database (from -' : tables or pass-through queries) that can be selected by the user. -'--------------------------------------------------------------------------------------- -' -Private Sub LoadSampleConnectionStrings() - - Dim dItems As Dictionary - Dim varKey As Variant - Dim varConn As Variant - Dim strCurrent As String - - ' Take advantage of our connection class to retrieve some example - ' connection strings from the current database. - With New clsDbConnection - Set dItems = .GetDictionary - End With - - ' Save current value, and rebuild list - strCurrent = Nz(cboConnect) - cboConnect.RowSource = vbNullString - - ' Loop through the connection strings - If Not dItems Is Nothing Then - For Each varKey In dItems.Keys - For Each varConn In dItems(varKey) - If Len(varConn) > 10 Then - ' Looks like a connection string. Add to list. - cboConnect.AddItem """" & varConn & """" - End If - Next varConn - Next varKey - End If - - ' Restore original value - cboConnect = strCurrent - -End Sub +' See "frmVCSDatabase.cls" diff --git a/Version Control.accda.src/forms/frmVCSDatabase.cls b/Version Control.accda.src/forms/frmVCSDatabase.cls new file mode 100644 index 00000000..ee93f1a0 --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSDatabase.cls @@ -0,0 +1,429 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + + +' Store original name, just in case we rename an existing entry. +Private m_strOriginalName As String + + +'--------------------------------------------------------------------------------------- +' Procedure : LoadSchema +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Load a schema by name +'--------------------------------------------------------------------------------------- +' +Public Sub LoadSchema(strName As String, dSchema As Dictionary) + + Dim dParams As Dictionary + + ' Merge values into defaults to ensure that all values are defined + Set dParams = GetDefaults + MergeDictionary dParams, dSchema + MergeDotEnv strName, dParams + + ' Save original name, just in case it is renamed + m_strOriginalName = strName + + ' Load values from dictionary parameters + txtName = strName + chkEnabled = dParams("Enabled") + cboType = dParams("DatabaseType") + chkUtcDates = dParams("UtcDateTime") + txtDescription = dParams("Description") + txtFilter = ParseFilter(dParams("Filter")) + cboConnect = dParams("Connect") + chkSaveDotEnv = dParams("UseDotEnv") + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : ParseFilter +' Author : Adam Waller +' Date : 1/9/2024 +' Purpose : Parse the filter +'--------------------------------------------------------------------------------------- +' +Private Function ParseFilter(varValue As Variant) As String + + Dim varItem As Variant + + ' Convert collection to filter lines + With New clsConcat + .AppendOnAdd = vbCrLf + For Each varItem In varValue + .Add CStr(varItem) + Next varItem + If .Length > 2 Then .Remove 2 + ParseFilter = .GetStr + End With + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : MergeDotEnv +' Author : Adam Waller +' Date : 7/31/2023 +' Purpose : Merge any specified .env params into dictionary. (Will override schema +' : options saved in vcs-options.json) +'--------------------------------------------------------------------------------------- +' +Private Sub MergeDotEnv(strSchemaName As String, ByRef dParams As Dictionary) + Dim strFile As String + strFile = BuildPath2(Options.GetExportFolder & "databases", GetSafeFileName(strSchemaName), ".env") + If FSO.FileExists(strFile) Then + With New clsDotEnv + .LoadFromFile strFile + .MergeIntoDictionary dParams, False + End With + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : SaveConnectionString +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Saves the connection string to a .env file. +'--------------------------------------------------------------------------------------- +' +Private Sub SaveConnectionStringToFile() + + Dim strFile As String + + ' Guard clause safety check + If Nz(txtName) = vbNullString Or Nz(cboConnect) = vbNullString Then Exit Sub + + ' Update the value in the .env file. (Creating the file, if needed.) + strFile = BuildPath2(Options.GetExportFolder & "databases", GetSafeFileName(Nz(txtName)), ".env") + With New clsDotEnv + ' Reload file so we preserve existing values + .LoadFromFile strFile + .SetVar "CONNECT", Nz(cboConnect) + .SaveToFile strFile + End With + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdCancel_Click +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Close this form +'--------------------------------------------------------------------------------------- +' +Private Sub cmdCancel_Click() + DoCmd.Close acForm, Me.Name +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdExamples_Click +' Author : Adam Waller +' Date : 8/2/2023 +' Purpose : Show syntax examples on the Wiki +'--------------------------------------------------------------------------------------- +' +Private Sub cmdExamples_Click() + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdSaveAndClose_Click +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Save the schema back to the options form. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdSaveAndClose_Click() + If SaveConnection Then + Form_frmVCSOptions.RefreshSchemaList + DoCmd.Close acForm, Me.Name + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : SaveConnection +' Author : Adam Waller +' Date : 7/21/2023 +' Purpose : Save the current connection, return true if successful. +'--------------------------------------------------------------------------------------- +' +Private Function SaveConnection() As Boolean + + Dim dSchema As Dictionary + Dim strKey As String + + If Not PassedValidation Then Exit Function + + If IsLoaded(acForm, "frmVCSOptions") Then + With Form_frmVCSOptions + + ' Make sure we have a dictionary object + If .DatabaseSchemas Is Nothing Then Set .DatabaseSchemas = New Dictionary + + ' Save to options form + With .DatabaseSchemas + + ' Get a reference to dictionary object + strKey = Nz(txtName) + If Not .Exists(strKey) Then + ' Could be a rename + Set dSchema = New Dictionary + .Add strKey, dSchema + ' Remove any previous entry + If Len(m_strOriginalName) Then + If .Exists(m_strOriginalName) Then .Remove m_strOriginalName + End If + End If + + ' Load form values + SetParamsFromForm .Item(strKey) + + ' Connection string + If chkSaveDotEnv Then + CheckGitignoreDotEnv + ' Save connection string to .env file + SaveConnectionStringToFile + ' Remove connect parameter from dictionary + If .Item(strKey).Exists("Connect") Then .Item(strKey).Remove "Connect" + End If + End With + End With + + ' Return success + SaveConnection = True + Else + MsgBox2 "Options form not found", "The Options form must be open to save changes to external database connections", , vbExclamation + End If + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : SetParamsFromForm +' Author : Adam Waller +' Date : 7/31/2023 +' Purpose : Sets the dictionary parameters based on the current form values. +' : (This is especially helpful for testing filters before saving an entry.) +'--------------------------------------------------------------------------------------- +' +Private Sub SetParamsFromForm(ByRef dParams As Dictionary) + With dParams + .Item("Enabled") = CBool(chkEnabled) + .Item("DatabaseType") = CInt(cboType) + .Item("Description") = Nz(txtDescription) + .Item("UtcDateTime") = CBool(chkUtcDates) + .Item("Connect") = Nz(cboConnect) + .Item("UseDotEnv") = CBool(chkSaveDotEnv) + Set .Item("Filter") = ToCollection(Nz(txtFilter)) + End With +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : ToCollection +' Author : Adam Waller +' Date : 1/9/2024 +' Purpose : Convert a string list of items to a collection. (Split on vbCrLf) +'--------------------------------------------------------------------------------------- +' +Private Function ToCollection(strFilter) As Collection + + Dim colRules As Collection + Dim varLine As Variant + + Set colRules = New Collection + For Each varLine In Split(strFilter, vbCrLf) + colRules.Add CStr(varLine) + Next varLine + Set ToCollection = colRules + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : GetDefaults +' Author : Adam Waller +' Date : 7/31/2023 +' Purpose : Set the default values for connection parameters +'--------------------------------------------------------------------------------------- +' +Private Function GetDefaults() As Dictionary + Set GetDefaults = New Dictionary + With GetDefaults + .CompareMode = TextCompare + .Item("Enabled") = True + .Item("DatabaseType") = 1 + .Item("Description") = vbNullString + .Item("UtcDateTime") = False + .Item("Connect") = vbNullString + .Item("UseDotEnv") = True + Set .Item("Filter") = New Collection + End With +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : PassedValidation +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Return true if we pass validation on the form to save the entry. +'--------------------------------------------------------------------------------------- +' +Private Function PassedValidation() As Boolean + + Dim strMsg As String + + ' TODO: Could add more validation for filter entries + + If Len(Nz(cboConnect)) < 5 Then strMsg = "Please select or enter a connection string for database" + If Nz(cboType, -1) < 0 Then strMsg = "Please select database type" + If Len(Nz(txtName)) = 0 Then strMsg = "Connection name is required" + + If Len(strMsg) Then + MsgBox2 "Please fix validation issues to continue", strMsg, "See online wiki for additional documentation", vbExclamation + Else + PassedValidation = True + End If + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdTest_Click +' Author : Adam Waller +' Date : 7/21/2023 +' Purpose : Test the current filter and return the number of objects found. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdTest_Click() + + Dim cSchema As IDbSchema + Dim lngCount As Long + Dim dblStart As Double + Dim dParams As Dictionary + + txtFilter.SetFocus + txtFilter.SelStart = 9999 + If Not PassedValidation Then Exit Sub + + Select Case cboType + Case eDatabaseServerType.estMsSql + Set cSchema = New clsSchemaMsSql + Case eDatabaseServerType.estMySql + Set cSchema = New clsSchemaMySql + End Select + + ' Retrieve object count from server. + If Not cSchema Is Nothing Then + Set dParams = New Dictionary + dParams.CompareMode = TextCompare + SetParamsFromForm dParams + cSchema.Initialize dParams + dblStart = Perf.MicroTimer + DoCmd.Hourglass True + lngCount = cSchema.ObjectCount(False) + DoCmd.Hourglass False + MsgBox2 lngCount & " Objects Found", "A total of " & lngCount & " database objects were retrieved in " & _ + Round(Perf.MicroTimer - dblStart, 2) & " seconds.", , vbInformation + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : CheckGitignoreDotEnv +' Author : Adam Waller +' Date : 7/31/2023 +' Purpose : If the project appears to be a .git repository, check to see if .env +' : appears in the .gitignore file. +' : (This is not a comprehensive test, but just an extra aid for most common +' : scenarios to help users avoid inadvertently comitting a .env file to +' : their version control system.) +'--------------------------------------------------------------------------------------- +' +Private Sub CheckGitignoreDotEnv() + + Dim strPath As String + Dim strContent As String + + ' Guess at the standard location for a .gitignore file + strPath = Options.GetExportFolder & "..\.gitignore" + If FSO.FileExists(strPath) Then + strContent = ReadFile(strPath) + If Len(strContent) Then + If InStr(1, strContent, ".env", vbTextCompare) = 0 Then + MsgBox2 "Potentially Sensitive File", _ + "Please note: .env files should not be committed to version control.", _ + "To avoid exposing credentials to your repository, please exclude .env files in .gitignore", _ + vbExclamation + End If + End If + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Load +' Author : Adam Waller +' Date : 8/1/2023 +' Purpose : Load in sample connection strings from the current database. +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Load() + LoadSampleConnectionStrings +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : LoadSampleConnectionStrings +' Author : Adam Waller +' Date : 8/1/2023 +' Purpose : Loads in some sample connection strings from the current database (from +' : tables or pass-through queries) that can be selected by the user. +'--------------------------------------------------------------------------------------- +' +Private Sub LoadSampleConnectionStrings() + + Dim dItems As Dictionary + Dim varKey As Variant + Dim varConn As Variant + Dim strCurrent As String + + ' Take advantage of our connection class to retrieve some example + ' connection strings from the current database. + With New clsDbConnection + Set dItems = .GetDictionary + End With + + ' Save current value, and rebuild list + strCurrent = Nz(cboConnect) + cboConnect.RowSource = vbNullString + + ' Loop through the connection strings + If Not dItems Is Nothing Then + For Each varKey In dItems.Keys + For Each varConn In dItems(varKey) + If Len(varConn) > 10 Then + ' Looks like a connection string. Add to list. + cboConnect.AddItem """" & varConn & """" + End If + Next varConn + Next varKey + End If + + ' Restore original value + cboConnect = strCurrent + +End Sub diff --git a/Version Control.accda.src/forms/frmVCSInstall.bas b/Version Control.accda.src/forms/frmVCSInstall.bas index d6f1bf96..9443c755 100644 --- a/Version Control.accda.src/forms/frmVCSInstall.bas +++ b/Version Control.accda.src/forms/frmVCSInstall.bas @@ -1799,166 +1799,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Compare Database -Option Explicit - - -'--------------------------------------------------------------------------------------- -' Procedure : chkAdvancedOptions_Click -' Author : Adam Waller -' Date : 5/22/2023 -' Purpose : Toggle to show advanced install options. -'--------------------------------------------------------------------------------------- -' -Private Sub chkAdvancedOptions_Click() - tabInstallType = Not (chkAdvancedOptions - 1) -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdCancel_Click -' Author : Adam Waller -' Date : 2/4/2021 -' Purpose : Close form if user presses the escape key. (Cancel property = True) -'--------------------------------------------------------------------------------------- -' -Private Sub cmdCancel_Click() - DoCmd.Close acForm, Me.Name -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdInstall_Click -' Author : Adam Waller -' Date : 2/4/2021 -' Purpose : Install add-in using selected options. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdInstall_Click() - - Dim strFolder As String - Dim strFile As String - Dim strMsg As String - - ' Activate the hourglass before loading installer VBA module for somoother experince. - DoCmd.Hourglass True - DoEvents - - ' Validate the folder path - strFolder = StripSlash(Nz(txtInstallFolder)) - If StrComp(GetInstallSettings.strInstallFolder, strFolder, vbTextCompare) <> 0 Then - ' Using a custom install folder - If Not FSO.FolderExists(strFolder) Then - strMsg = "Folder does not exist: " & strFolder - Else - ' Test writing a file to make sure we have write access to this folder. - LogUnhandledErrors - On Error Resume Next - strFile = strFolder & PathSep & "WriteTest.txt" - WriteFile "Test", strFile - CatchAny eelNoError, vbNullString - If ReadFile(strFile) <> "Test" & vbCrLf Then strMsg = "Unable to write to folder: " & strFolder - End If - End If - - ' Resume normal error handling - If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next - - ' Bail out if we have a problem with the install. - If strMsg <> vbNullString Then - DoCmd.Hourglass False - MsgBox2 "Unable to Install", strMsg, , vbExclamation - Exit Sub - End If - - ' Run the installer - modInstall.InstallVCSAddin chkAddTrustedLocation, chkUseRibbon, chkOpenAfterInstall, txtInstallFolder, Me.chkCreateCompiledVersion.Value - DoCmd.Hourglass False - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdChangeInstallFolder_Click -' Author : Adam Waller -' Date : 5/22/2023 -' Purpose : Allow the user to select another location for installation. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdChangeInstallFolder_Click() - - ' See if the add-in is already installed - If FSO.FileExists(GetAddInFileName) Then - MsgBox2 "Please Uninstall First" _ - , "Please uninstall (and delete) the add-in, then reinstall to the new location. " & _ - "If you have already uninstalled, delete the addin file. " & _ - "The install folder will open now to allow you to delete the file." _ - , "You will have the option to keep your current settings during the uninstall process." _ - , vbExclamation - - Application.FollowHyperlink GetInstallSettings.strInstallFolder - - Else - ' Show a folder picker to select the desired location. - ' (The path will be validated before installation, just in case it is changed direclty in the text box.) - With Application.FileDialog(msoFileDialogFolderPicker) - .AllowMultiSelect = False - .ButtonName = "Select Folder" - .InitialFileName = GetInstallSettings.strInstallFolder - .Title = "Select " & PROJECT_NAME & " Install folder" - .Show - If .SelectedItems.Count > 0 Then - ' Selected a folder - txtInstallFolder = .SelectedItems(1) - Else - ' Canceled dialog - Exit Sub - End If - End With - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Load -' Author : Adam Waller -' Date : 4/15/2020 -' Purpose : Setting the control source causes delayed display. This way the display -' : is instant when the form is opened. -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Load() - - Const STYLE_NO_TABS As Integer = 2 - - ' Change install type tab control to no tabs and no border - tabInstallType.Style = STYLE_NO_TABS - tabInstallType.BorderStyle = 0 - - ' Display version (better performance than bound control) - lblVersion.Caption = "Version " & GetVCSVersion() - - With GetInstallSettings - chkAddTrustedLocation = .blnTrustAddInFolder - chkOpenAfterInstall = .blnOpenAfterInstall - chkUseRibbon = .blnUseRibbonAddIn - With txtInstallFolder - .Value = GetInstallSettings.strInstallFolder - .Locked = True ' Only enable this text box if not installed. - .BackColor = IIf(.Locked, 15921906, 16777215) - End With - End With - - ' Show installed version - If InstalledVersion = vbNullString Then - lblInstalled.Caption = "(Add-in not currently installed)" - Else - lblInstalled.Caption = "Version " & InstalledVersion & " currently installed." - End If - -End Sub +' See "frmVCSInstall.cls" \ No newline at end of file diff --git a/Version Control.accda.src/forms/frmVCSInstall.cls b/Version Control.accda.src/forms/frmVCSInstall.cls new file mode 100644 index 00000000..8f996c98 --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSInstall.cls @@ -0,0 +1,163 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + + +'--------------------------------------------------------------------------------------- +' Procedure : chkAdvancedOptions_Click +' Author : Adam Waller +' Date : 5/22/2023 +' Purpose : Toggle to show advanced install options. +'--------------------------------------------------------------------------------------- +' +Private Sub chkAdvancedOptions_Click() + tabInstallType = Not (chkAdvancedOptions - 1) +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdCancel_Click +' Author : Adam Waller +' Date : 2/4/2021 +' Purpose : Close form if user presses the escape key. (Cancel property = True) +'--------------------------------------------------------------------------------------- +' +Private Sub cmdCancel_Click() + DoCmd.Close acForm, Me.Name +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdInstall_Click +' Author : Adam Waller +' Date : 2/4/2021 +' Purpose : Install add-in using selected options. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdInstall_Click() + + Dim strFolder As String + Dim strFile As String + Dim strMsg As String + + ' Activate the hourglass before loading installer VBA module for somoother experince. + DoCmd.Hourglass True + DoEvents + + ' Validate the folder path + strFolder = StripSlash(Nz(txtInstallFolder)) + If StrComp(GetInstallSettings.strInstallFolder, strFolder, vbTextCompare) <> 0 Then + ' Using a custom install folder + If Not FSO.FolderExists(strFolder) Then + strMsg = "Folder does not exist: " & strFolder + Else + ' Test writing a file to make sure we have write access to this folder. + LogUnhandledErrors + On Error Resume Next + strFile = strFolder & PathSep & "WriteTest.txt" + WriteFile "Test", strFile + CatchAny eelNoError, vbNullString + If ReadFile(strFile) <> "Test" & vbCrLf Then strMsg = "Unable to write to folder: " & strFolder + End If + End If + + ' Resume normal error handling + If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next + + ' Bail out if we have a problem with the install. + If strMsg <> vbNullString Then + DoCmd.Hourglass False + MsgBox2 "Unable to Install", strMsg, , vbExclamation + Exit Sub + End If + + ' Run the installer + modInstall.InstallVCSAddin chkAddTrustedLocation, chkUseRibbon, chkOpenAfterInstall, txtInstallFolder + DoCmd.Hourglass False + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdChangeInstallFolder_Click +' Author : Adam Waller +' Date : 5/22/2023 +' Purpose : Allow the user to select another location for installation. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdChangeInstallFolder_Click() + + ' See if the add-in is already installed + If FSO.FileExists(GetAddInFileName) Then + MsgBox2 "Please Uninstall First" _ + , "Please uninstall (and delete) the add-in, then reinstall to the new location. " & _ + "If you have already uninstalled, delete the addin file. " & _ + "The install folder will open now to allow you to delete the file." _ + , "You will have the option to keep your current settings during the uninstall process." _ + , vbExclamation + + Application.FollowHyperlink GetInstallSettings.strInstallFolder + + Else + ' Show a folder picker to select the desired location. + ' (The path will be validated before installation, just in case it is changed direclty in the text box.) + With Application.FileDialog(msoFileDialogFolderPicker) + .AllowMultiSelect = False + .ButtonName = "Select Folder" + .InitialFileName = GetInstallSettings.strInstallFolder + .Title = "Select " & PROJECT_NAME & " Install folder" + .Show + If .SelectedItems.Count > 0 Then + ' Selected a folder + txtInstallFolder = .SelectedItems(1) + Else + ' Canceled dialog + Exit Sub + End If + End With + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Load +' Author : Adam Waller +' Date : 4/15/2020 +' Purpose : Setting the control source causes delayed display. This way the display +' : is instant when the form is opened. +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Load() + + Const STYLE_NO_TABS As Integer = 2 + + ' Change install type tab control to no tabs and no border + tabInstallType.Style = STYLE_NO_TABS + tabInstallType.BorderStyle = 0 + + ' Display version (better performance than bound control) + lblVersion.Caption = "Version " & GetVCSVersion() + + With GetInstallSettings + chkAddTrustedLocation = .blnTrustAddInFolder + chkOpenAfterInstall = .blnOpenAfterInstall + chkUseRibbon = .blnUseRibbonAddIn + With txtInstallFolder + .Value = GetInstallSettings.strInstallFolder + .Locked = True ' Only enable this text box if not installed. + .BackColor = IIf(.Locked, 15921906, 16777215) + End With + End With + + ' Show installed version + If InstalledVersion = vbNullString Then + lblInstalled.Caption = "(Add-in not currently installed)" + Else + lblInstalled.Caption = "Version " & InstalledVersion & " currently installed." + End If + +End Sub diff --git a/Version Control.accda.src/forms/frmVCSMain.bas b/Version Control.accda.src/forms/frmVCSMain.bas index bdfc5463..2201c9e2 100644 --- a/Version Control.accda.src/forms/frmVCSMain.bas +++ b/Version Control.accda.src/forms/frmVCSMain.bas @@ -1722,527 +1722,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -'--------------------------------------------------------------------------------------- -' Module : Form_frmVCSMain -' Author : Adam Waller -' Date : 3/30/2022 -' Purpose : Main form for performing an export or build operation. -' : This color scheme can be changed, I just wanted something more aesthetically -' : pleasing than the default wizards and forms. -' : Color scheme: https://coolors.co/383f51-e0e0e6-ffffff-ef8354-d3d7ef -'--------------------------------------------------------------------------------------- -Option Compare Database -Option Explicit - - -' This property can be set to export or merge a specific subset of containers -Public intContainerFilter As eContainerFilter - -' Used for exporting or loading a single object -Public objSingleObject As AccessObject - -' Path to the last log file, in case the user wants to view the log after the operation. -' (The Log object has already been reset at this point, so we can't use Log.LogFilePath.) -Public strLastLogFilePath As String - -' Use this property to set the path to the source files (such as a build triggered from the API) -Public strSourcePath As String - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdBuild_Click -' Author : Adam Waller -' Date : 5/4/2020 -' Purpose : Initiate the process to build from source -'--------------------------------------------------------------------------------------- -' -Public Sub cmdBuild_Click() - - Dim strFolder As String - - ' Make sure we use the add-in to build the add-in. - If CodeProject.FullName = CurrentProject.FullName Then - MsgBox2 "Build must be run from Add-In", "Instead of opening this form to build the add-in," & vbCrLf & _ - "please install and use the Version Control add-in from the Add-in menu", , vbExclamation - DoCmd.Hourglass False - Exit Sub - End If - - ' Get source files folder - If Len(Me.strSourcePath) Then - ' Use specified build folder - strFolder = Me.strSourcePath - Else - ' Attempt to get the source folder from the current database, or from - ' a folder picker dialog. - strFolder = GetSourceFolder - ' Exit out of build if the user cancelled any of the confirmations. - If strFolder = vbNullString Then Exit Sub - End If - - ' Build project using the selected source folder - ' (Use a timer so we can release the reference to this form before beginning the - ' build process, just in case we need to import a form with the same name.) - If strFolder <> vbNullString Then SetTimer "Build", strFolder, chkFullBuild - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : GetSourceFolder -' Author : Adam Waller -' Date : 10/19/2023 -' Purpose : Return the source files folder from either the currently open database -' : or from a folder picker dialog. (Returns an empty string if the user -' : cancels the selection.) -'--------------------------------------------------------------------------------------- -' -Private Function GetSourceFolder() As String - - Dim strMsg(0 To 2) As String - Dim intChoice As VbMsgBoxResult - - DoCmd.Hourglass True - DoEvents - - ' Close the current database if it is currently open. - If DatabaseFileOpen Then - If FolderHasVcsOptionsFile(Options.GetExportFolder) Then - strMsg(0) = "Build " & CurrentVBProject.Name & " (" & CurrentProject.Name & ") from source?" - If chkFullBuild Then - strMsg(1) = "Click 'Yes' to rebuild* this database from source files in this folder:" & vbCrLf & Options.GetExportFolder & vbCrLf & _ - "* (This database will be renamed as a backup before building " & CurrentProject.Name & " from source.)" - Else - strMsg(1) = "Click 'Yes' to merge* any changed source files into this database." & vbCrLf & _ - "* (A backup of this database will be created before importing any source files.)" - End If - strMsg(2) = "Click 'No' to select another project, or 'Cancel' to go back to the previous screen." - If Not chkFullBuild And Not Me.Visible Then - ' Skip confirmation for merge build initiated from Ribbon - intChoice = vbYes - Else - ' Require user confirmation for full builds, or if main form is visible. - intChoice = MsgBox2(strMsg(0), strMsg(1), strMsg(2), vbYesNoCancel + vbQuestion + vbDefaultButton3, , vbYes) - End If - If intChoice = vbYes Then - ' Rebuild the open project - GetSourceFolder = Options.GetExportFolder - ElseIf intChoice = vbCancel Then - ' Canceled out of build option. - DoCmd.Hourglass False - Exit Function - End If - End If - End If - - ' If we aren't doing the current database, then prompt user to find a folder - ' with source files to use for the build. - If GetSourceFolder = vbNullString Then - - ' Show a folder picker to select the file with source code. - DoCmd.Hourglass False - With Application.FileDialog(msoFileDialogFolderPicker) - .AllowMultiSelect = False - .ButtonName = "Select Source Files Folder" - '.InitialFileName = Options.GetExportFolder - .Title = "Select Source Folder" - .Show - If .SelectedItems.Count > 0 Then - ' Selected a folder - If FolderHasVcsOptionsFile(.SelectedItems(1)) Then - ' Has source files - GetSourceFolder = .SelectedItems(1) & PathSep - DoCmd.Hourglass True - Else - MsgBox2 "Source files not found", "Required source files were not found in this folder.", _ - "You selected: " & .SelectedItems(1), vbExclamation - Exit Function - End If - Else - ' Canceled dialog - Exit Function - End If - End With - End If - -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : BuildFromSource -' Author : Adam Waller -' Date : 5/4/2020 -' Purpose : Show the GUI for building the database from source. -'--------------------------------------------------------------------------------------- -' -Public Sub StartBuild(blnFullBuild As Boolean) - - Dim strType As String - - cmdClose.SetFocus - HideActionButtons - DoEvents - With txtLog - .ScrollBars = 0 - .Visible = True - .SetFocus - End With - Log.SetConsole Me.txtLog, GetProgressBar - Me.Visible = True - - ' Show the status - strType = IIf(blnFullBuild, "Building", "Merging") - SetStatusText "Running...", strType & " From Source", _ - "A summary of the build progress can be seen on this screen, and additional details are included in the log file." - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : FinishBuild -' Author : Adam Waller -' Date : 5/4/2020 -' Purpose : Finish the build process -'--------------------------------------------------------------------------------------- -' -Public Sub FinishBuild(blnFullBuild As Boolean) 'Optional strType As String = "Build") - - Dim strType As String - - ' Turn on scroll bars in case the user wants to scroll back through the log. - txtLog.ScrollBars = 2 - - ' Display final UI messages. - Log.Flush - strType = IIf(blnFullBuild, "Build", "Merge") - SetStatusText "Finished", strType & " Complete", _ - "Additional details can be found in the project " & LCase(strType) & " log file.

You may now close this window." - cmdOpenLogFile.Visible = (Log.LogFilePath <> vbNullString) - Me.strLastLogFilePath = Log.LogFilePath - - ' Close form if running in silent mode (such as when running automated builds) - If InteractionMode = eimSilent Then DoCmd.Close acForm, Me.Name - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : chkFullBuild_Click -' Author : Adam Waller -' Date : 6/2/2023 -' Purpose : -'--------------------------------------------------------------------------------------- -' -Private Sub chkFullBuild_Click() - SetBuildCaption -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : SetBuildCaption -' Author : Adam Waller -' Date : 6/2/2023 -' Purpose : Set the appropriate caption for the build/merge button. -'--------------------------------------------------------------------------------------- -' -Private Sub SetBuildCaption() - cmdBuild.Caption = IIf(chkFullBuild, _ - " Build from Source", _ - " Merge from Source") -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdClose_Click -' Author : Adam Waller -' Date : 1/14/2020 -' Purpose : Close the form -'--------------------------------------------------------------------------------------- -' -Private Sub cmdClose_Click() - ' Ignore the error if the user resumes (cancels the close operation) - LogUnhandledErrors - On Error Resume Next - DoCmd.Close acForm, Me.Name - Catch 2501 ' Close form was canceled. -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : ConfirmCancel -' Author : Adam Waller -' Date : 7/8/2021 -' Purpose : Confirm that the user really wants to cancel the current operation. -'--------------------------------------------------------------------------------------- -' -Private Function ConfirmCancel() As Boolean - ConfirmCancel = MsgBox2("Cancel Current Operation?", _ - "You are in the midst of a running process. Are you sure you want to cancel?", _ - "Click [Yes] to cancel the process, or [No] to resume.", _ - vbYesNo + vbDefaultButton2 + vbExclamation, , vbYes) = vbYes -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdExport_Click -' Author : Adam Waller -' Date : 1/14/2020 -' Purpose : Export source code from current database -'--------------------------------------------------------------------------------------- -' -Public Sub cmdExport_Click() - - cmdClose.SetFocus - HideActionButtons - DoEvents - With txtLog - .ScrollBars = 0 - .Visible = True - .SetFocus - End With - Log.SetConsole Me.txtLog, GetProgressBar - - ' Show the status - SetStatusText "Running...", "Exporting source code", _ - "A summary of the export progress can be seen on this screen, and additional details are included in the log file." - - ' See if we are exporting a single object, or everything. - If Me.objSingleObject Is Nothing Then - ' Export the source code using the specified filter. - modImportExport.ExportSource chkFullExport, Me.intContainerFilter, Me - Else - modImportExport.ExportSingleObject Me.objSingleObject, Me - End If - - ' Turn on scroll bars in case the user wants to scroll back through the log. - txtLog.ScrollBars = 2 - Log.Flush - - ' Don't attempt to access controls if we are in the process of closing the form. - If FormLoaded(Me) Then - SetStatusText "Finished", "Export Complete", _ - "Additional details can be found in the project export log file.

You may now close this window." - cmdOpenLogFile.Visible = (Me.strLastLogFilePath <> vbNullString) - Me.strLastLogFilePath = Me.strLastLogFilePath - DoEvents - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : HideActionButtons -' Author : Adam Waller -' Date : 1/14/2020 -' Purpose : Hide the action buttons when running a command. -'--------------------------------------------------------------------------------------- -' -Public Sub HideActionButtons() - cmdExport.Visible = False - chkFullExport.Visible = False - cmdBuild.Visible = False - chkFullBuild.Visible = False - cmdOptions.Visible = False - cmdHelp.Visible = False -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdHelp_Click -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Go to the GitHub documentation page. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdHelp_Click() - Application.FollowHyperlink "https://github.com/joyfullservice/msaccess-vcs-addin/wiki/Documentation" -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdOptions_Click -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Open options dialog (for this project) -'--------------------------------------------------------------------------------------- -' -Private Sub cmdOptions_Click() - ' Force reload of options from current project before opening the form. - Set Options = Nothing - Form_frmVCSOptions.Visible = True -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Load -' Author : Adam Waller -' Date : 4/15/2020 -' Purpose : Setting the control source causes delayed display. This way the display -' : is instant when the form is opened. -'--------------------------------------------------------------------------------------- -' -Public Sub Form_Load() - - ' Display version (better performance than bound control) - lblVersion.Caption = "Version " & GetVCSVersion() - - SetStatusText "Choose Action", "What would you like to do?", _ - "Export source to generate source files from the current database." & _ - "

Import source files to rebuild this database from source." - - ' Set defaults based on current options. - chkFullBuild = Not Options.UseMergeBuild - chkFullExport = Not Options.UseFastSave - - ' You can only export if you have a database open. - cmdExport.Enabled = DatabaseFileOpen - chkFullExport.Enabled = DatabaseFileOpen - - If DatabaseFileOpen Then - - ' Require full export after options change - If VCSIndex.OptionsHash <> Options.GetHash Then - chkFullExport = True - chkFullExport.Enabled = False - End If - - ' Merge build only available after full build. - ' (Attempting a merge build of the entire database may - ' not work correctly due to objects that depend upon - ' each other.) - If VCSIndex.FullBuildDate = 0 Then - chkFullBuild = True - chkFullBuild.Enabled = False - End If - End If - - ' Set caption on build button - SetBuildCaption - - ' Turn off the timer, just in case it was left on. - Me.TimerInterval = 0 - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : AutoClose -' Author : Adam Waller -' Date : 5/6/2021 -' Purpose : Use the timer to automatically close the form in 2 seconds. -' : (This keeps the application from "hanging" during the pause between -' : completion and close.) -'--------------------------------------------------------------------------------------- -' -Public Sub AutoClose() - 'The procedure may be called when the form has been closed. - 'In this case, a VBA error may occur, so we check if the - 'form is loaded before setting the property. We do not use - 'the Me.Name because that would be also an error. - If IsLoaded(acForm, "frmVCSMain", False) Then - Me.TimerInterval = 2000 - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Timer -' Author : Adam Waller -' Date : 5/6/2021 -' Purpose : Automatically close form. -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Timer() - Me.TimerInterval = 0 - cmdClose_Click -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : SetStatusText -' Author : Adam Waller -' Date : 4/21/2020 -' Purpose : Update the status text to direct the user to the next task, or show the -' : status of the current operation. -'--------------------------------------------------------------------------------------- -' -Public Sub SetStatusText(strHeading As String, strSubHeading As String, strDescriptionHtml As String) - If Not FormLoaded(Me) Then Exit Sub - lblHeading.Caption = strHeading - lblSubheading.Caption = strSubHeading - txtDescription.Value = strDescriptionHtml -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : GetProgressBar -' Author : Adam Waller -' Date : 11/6/2020 -' Purpose : Set up the progress bar. -'--------------------------------------------------------------------------------------- -' -Public Function GetProgressBar() As clsLblProg - - Dim cProg As clsLblProg - - ' Create a new progress bar class, and initialize with form controls - Set cProg = New clsLblProg - cProg.Initialize lblProgBack, lblProgFront, lblProgCaption - cProg.SetRepaintInterval 0.5 - - ' Move caption up slightly for better alignment on this very small progress bar - lblProgCaption.Top = lblProgBack.Top + 1 - - ' Return reference to caller - Set GetProgressBar = cProg - -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Unload -' Author : Adam Waller -' Date : 7/8/2021 -' Purpose : Verify that the user wants to cancel the current operation -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Unload(Cancel As Integer) - - Static intAttempt As Integer - - ' Allow the form to close on the third attempt, just in case the log - ' is stuck in active status for some reason. - If intAttempt > 2 Then Exit Sub - - ' Check to see if we have an active job running. - If Log.Active Then - If ConfirmCancel Then Log.Error eelCritical, "Canceled Operation", Me.Name & ".Form_Unload" - ' Either way, we want the log to complete first. - Cancel = True - intAttempt = intAttempt + 1 - End If - - ' Release the log console if we are closing the form - If Not Cancel Then Log.ReleaseConsole - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdOpenLogFile_Click -' Author : Adam Waller -' Date : 11/6/2020 -' Purpose : Open the log file -'--------------------------------------------------------------------------------------- -' -Private Sub cmdOpenLogFile_Click() - cmdClose.SetFocus - If FSO.FileExists(strLastLogFilePath) Then - ' (Note, parentheses are required for the path argument) - CreateObject("Shell.Application").Open (strLastLogFilePath) - End If -End Sub +' See "frmVCSMain.cls" \ No newline at end of file diff --git a/Version Control.accda.src/forms/frmVCSMain.cls b/Version Control.accda.src/forms/frmVCSMain.cls new file mode 100644 index 00000000..ec505b81 --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSMain.cls @@ -0,0 +1,524 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Module : Form_frmVCSMain +' Author : Adam Waller +' Date : 3/30/2022 +' Purpose : Main form for performing an export or build operation. +' : This color scheme can be changed, I just wanted something more aesthetically +' : pleasing than the default wizards and forms. +' : Color scheme: https://coolors.co/383f51-e0e0e6-ffffff-ef8354-d3d7ef +'--------------------------------------------------------------------------------------- +Option Compare Database +Option Explicit + + +' This property can be set to export or merge a specific subset of containers +Public intContainerFilter As eContainerFilter + +' Used for exporting or loading a single object +Public objSingleObject As AccessObject + +' Path to the last log file, in case the user wants to view the log after the operation. +' (The Log object has already been reset at this point, so we can't use Log.LogFilePath.) +Public strLastLogFilePath As String + +' Use this property to set the path to the source files (such as a build triggered from the API) +Public strSourcePath As String + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdBuild_Click +' Author : Adam Waller +' Date : 5/4/2020 +' Purpose : Initiate the process to build from source +'--------------------------------------------------------------------------------------- +' +Public Sub cmdBuild_Click() + + Dim strFolder As String + + ' Make sure we use the add-in to build the add-in. + If CodeProject.FullName = CurrentProject.FullName Then + MsgBox2 "Build must be run from Add-In", "Instead of opening this form to build the add-in," & vbCrLf & _ + "please install and use the Version Control add-in from the Add-in menu", , vbExclamation + DoCmd.Hourglass False + Exit Sub + End If + + ' Get source files folder + If Len(Me.strSourcePath) Then + ' Use specified build folder + strFolder = Me.strSourcePath + Else + ' Attempt to get the source folder from the current database, or from + ' a folder picker dialog. + strFolder = GetSourceFolder + ' Exit out of build if the user cancelled any of the confirmations. + If strFolder = vbNullString Then Exit Sub + End If + + ' Build project using the selected source folder + ' (Use a timer so we can release the reference to this form before beginning the + ' build process, just in case we need to import a form with the same name.) + If strFolder <> vbNullString Then SetTimer "Build", strFolder, chkFullBuild + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : GetSourceFolder +' Author : Adam Waller +' Date : 10/19/2023 +' Purpose : Return the source files folder from either the currently open database +' : or from a folder picker dialog. (Returns an empty string if the user +' : cancels the selection.) +'--------------------------------------------------------------------------------------- +' +Private Function GetSourceFolder() As String + + Dim strMsg(0 To 2) As String + Dim intChoice As VbMsgBoxResult + + DoCmd.Hourglass True + DoEvents + + ' Close the current database if it is currently open. + If DatabaseFileOpen Then + If FolderHasVcsOptionsFile(Options.GetExportFolder) Then + strMsg(0) = "Build " & CurrentVBProject.Name & " (" & CurrentProject.Name & ") from source?" + If chkFullBuild Then + strMsg(1) = "Click 'Yes' to rebuild* this database from source files in this folder:" & vbCrLf & Options.GetExportFolder & vbCrLf & _ + "* (This database will be renamed as a backup before building " & CurrentProject.Name & " from source.)" + Else + strMsg(1) = "Click 'Yes' to merge* any changed source files into this database." & vbCrLf & _ + "* (A backup of this database will be created before importing any source files.)" + End If + strMsg(2) = "Click 'No' to select another project, or 'Cancel' to go back to the previous screen." + If Not chkFullBuild And Not Me.Visible Then + ' Skip confirmation for merge build initiated from Ribbon + intChoice = vbYes + Else + ' Require user confirmation for full builds, or if main form is visible. + intChoice = MsgBox2(strMsg(0), strMsg(1), strMsg(2), vbYesNoCancel + vbQuestion + vbDefaultButton3, , vbYes) + End If + If intChoice = vbYes Then + ' Rebuild the open project + GetSourceFolder = Options.GetExportFolder + ElseIf intChoice = vbCancel Then + ' Canceled out of build option. + DoCmd.Hourglass False + Exit Function + End If + End If + End If + + ' If we aren't doing the current database, then prompt user to find a folder + ' with source files to use for the build. + If GetSourceFolder = vbNullString Then + + ' Show a folder picker to select the file with source code. + DoCmd.Hourglass False + With Application.FileDialog(msoFileDialogFolderPicker) + .AllowMultiSelect = False + .ButtonName = "Select Source Files Folder" + '.InitialFileName = Options.GetExportFolder + .Title = "Select Source Folder" + .Show + If .SelectedItems.Count > 0 Then + ' Selected a folder + If FolderHasVcsOptionsFile(.SelectedItems(1)) Then + ' Has source files + GetSourceFolder = .SelectedItems(1) & PathSep + DoCmd.Hourglass True + Else + MsgBox2 "Source files not found", "Required source files were not found in this folder.", _ + "You selected: " & .SelectedItems(1), vbExclamation + Exit Function + End If + Else + ' Canceled dialog + Exit Function + End If + End With + End If + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : BuildFromSource +' Author : Adam Waller +' Date : 5/4/2020 +' Purpose : Show the GUI for building the database from source. +'--------------------------------------------------------------------------------------- +' +Public Sub StartBuild(blnFullBuild As Boolean) + + Dim strType As String + + cmdClose.SetFocus + HideActionButtons + DoEvents + With txtLog + .ScrollBars = 0 + .Visible = True + .SetFocus + End With + Log.SetConsole Me.txtLog, GetProgressBar + Me.Visible = True + + ' Show the status + strType = IIf(blnFullBuild, "Building", "Merging") + SetStatusText "Running...", strType & " From Source", _ + "A summary of the build progress can be seen on this screen, and additional details are included in the log file." + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : FinishBuild +' Author : Adam Waller +' Date : 5/4/2020 +' Purpose : Finish the build process +'--------------------------------------------------------------------------------------- +' +Public Sub FinishBuild(blnFullBuild As Boolean) 'Optional strType As String = "Build") + + Dim strType As String + + ' Turn on scroll bars in case the user wants to scroll back through the log. + txtLog.ScrollBars = 2 + + ' Display final UI messages. + Log.Flush + strType = IIf(blnFullBuild, "Build", "Merge") + SetStatusText "Finished", strType & " Complete", _ + "Additional details can be found in the project " & LCase(strType) & " log file.

You may now close this window." + cmdOpenLogFile.Visible = (Log.LogFilePath <> vbNullString) + Me.strLastLogFilePath = Log.LogFilePath + + ' Close form if running in silent mode (such as when running automated builds) + If InteractionMode = eimSilent Then DoCmd.Close acForm, Me.Name + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : chkFullBuild_Click +' Author : Adam Waller +' Date : 6/2/2023 +' Purpose : +'--------------------------------------------------------------------------------------- +' +Private Sub chkFullBuild_Click() + SetBuildCaption +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : SetBuildCaption +' Author : Adam Waller +' Date : 6/2/2023 +' Purpose : Set the appropriate caption for the build/merge button. +'--------------------------------------------------------------------------------------- +' +Private Sub SetBuildCaption() + cmdBuild.Caption = IIf(chkFullBuild, _ + " Build from Source", _ + " Merge from Source") +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdClose_Click +' Author : Adam Waller +' Date : 1/14/2020 +' Purpose : Close the form +'--------------------------------------------------------------------------------------- +' +Private Sub cmdClose_Click() + ' Ignore the error if the user resumes (cancels the close operation) + LogUnhandledErrors + On Error Resume Next + DoCmd.Close acForm, Me.Name + Catch 2501 ' Close form was canceled. +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : ConfirmCancel +' Author : Adam Waller +' Date : 7/8/2021 +' Purpose : Confirm that the user really wants to cancel the current operation. +'--------------------------------------------------------------------------------------- +' +Private Function ConfirmCancel() As Boolean + ConfirmCancel = MsgBox2("Cancel Current Operation?", _ + "You are in the midst of a running process. Are you sure you want to cancel?", _ + "Click [Yes] to cancel the process, or [No] to resume.", _ + vbYesNo + vbDefaultButton2 + vbExclamation, , vbYes) = vbYes +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdExport_Click +' Author : Adam Waller +' Date : 1/14/2020 +' Purpose : Export source code from current database +'--------------------------------------------------------------------------------------- +' +Public Sub cmdExport_Click() + + cmdClose.SetFocus + HideActionButtons + DoEvents + With txtLog + .ScrollBars = 0 + .Visible = True + .SetFocus + End With + Log.SetConsole Me.txtLog, GetProgressBar + + ' Show the status + SetStatusText "Running...", "Exporting source code", _ + "A summary of the export progress can be seen on this screen, and additional details are included in the log file." + + ' See if we are exporting a single object, or everything. + If Me.objSingleObject Is Nothing Then + ' Export the source code using the specified filter. + modImportExport.ExportSource chkFullExport, Me.intContainerFilter, Me + Else + modImportExport.ExportSingleObject Me.objSingleObject, Me + End If + + ' Turn on scroll bars in case the user wants to scroll back through the log. + txtLog.ScrollBars = 2 + Log.Flush + + ' Don't attempt to access controls if we are in the process of closing the form. + If FormLoaded(Me) Then + SetStatusText "Finished", "Export Complete", _ + "Additional details can be found in the project export log file.

You may now close this window." + cmdOpenLogFile.Visible = (Me.strLastLogFilePath <> vbNullString) + Me.strLastLogFilePath = Me.strLastLogFilePath + DoEvents + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : HideActionButtons +' Author : Adam Waller +' Date : 1/14/2020 +' Purpose : Hide the action buttons when running a command. +'--------------------------------------------------------------------------------------- +' +Public Sub HideActionButtons() + cmdExport.Visible = False + chkFullExport.Visible = False + cmdBuild.Visible = False + chkFullBuild.Visible = False + cmdOptions.Visible = False + cmdHelp.Visible = False +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdHelp_Click +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Go to the GitHub documentation page. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdHelp_Click() + Application.FollowHyperlink "https://github.com/joyfullservice/msaccess-vcs-addin/wiki/Documentation" +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdOptions_Click +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Open options dialog (for this project) +'--------------------------------------------------------------------------------------- +' +Private Sub cmdOptions_Click() + ' Force reload of options from current project before opening the form. + Set Options = Nothing + Form_frmVCSOptions.Visible = True +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Load +' Author : Adam Waller +' Date : 4/15/2020 +' Purpose : Setting the control source causes delayed display. This way the display +' : is instant when the form is opened. +'--------------------------------------------------------------------------------------- +' +Public Sub Form_Load() + + ' Display version (better performance than bound control) + lblVersion.Caption = "Version " & GetVCSVersion() + + SetStatusText "Choose Action", "What would you like to do?", _ + "Export source to generate source files from the current database." & _ + "

Import source files to rebuild this database from source." + + ' Set defaults based on current options. + chkFullBuild = Not Options.UseMergeBuild + chkFullExport = Not Options.UseFastSave + + ' You can only export if you have a database open. + cmdExport.Enabled = DatabaseFileOpen + chkFullExport.Enabled = DatabaseFileOpen + + If DatabaseFileOpen Then + + ' Require full export after options change + If VCSIndex.OptionsHash <> Options.GetHash Then + chkFullExport = True + chkFullExport.Enabled = False + End If + + ' Merge build only available after full build. + ' (Attempting a merge build of the entire database may + ' not work correctly due to objects that depend upon + ' each other.) + If VCSIndex.FullBuildDate = 0 Then + chkFullBuild = True + chkFullBuild.Enabled = False + End If + End If + + ' Set caption on build button + SetBuildCaption + + ' Turn off the timer, just in case it was left on. + Me.TimerInterval = 0 + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : AutoClose +' Author : Adam Waller +' Date : 5/6/2021 +' Purpose : Use the timer to automatically close the form in 2 seconds. +' : (This keeps the application from "hanging" during the pause between +' : completion and close.) +'--------------------------------------------------------------------------------------- +' +Public Sub AutoClose() + 'The procedure may be called when the form has been closed. + 'In this case, a VBA error may occur, so we check if the + 'form is loaded before setting the property. We do not use + 'the Me.Name because that would be also an error. + If IsLoaded(acForm, "frmVCSMain", False) Then + Me.TimerInterval = 2000 + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Timer +' Author : Adam Waller +' Date : 5/6/2021 +' Purpose : Automatically close form. +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Timer() + Me.TimerInterval = 0 + cmdClose_Click +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : SetStatusText +' Author : Adam Waller +' Date : 4/21/2020 +' Purpose : Update the status text to direct the user to the next task, or show the +' : status of the current operation. +'--------------------------------------------------------------------------------------- +' +Public Sub SetStatusText(strHeading As String, strSubHeading As String, strDescriptionHtml As String) + If Not FormLoaded(Me) Then Exit Sub + lblHeading.Caption = strHeading + lblSubheading.Caption = strSubHeading + txtDescription.Value = strDescriptionHtml +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : GetProgressBar +' Author : Adam Waller +' Date : 11/6/2020 +' Purpose : Set up the progress bar. +'--------------------------------------------------------------------------------------- +' +Public Function GetProgressBar() As clsLblProg + + Dim cProg As clsLblProg + + ' Create a new progress bar class, and initialize with form controls + Set cProg = New clsLblProg + cProg.Initialize lblProgBack, lblProgFront, lblProgCaption + cProg.SetRepaintInterval 0.5 + + ' Move caption up slightly for better alignment on this very small progress bar + lblProgCaption.Top = lblProgBack.Top + 1 + + ' Return reference to caller + Set GetProgressBar = cProg + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Unload +' Author : Adam Waller +' Date : 7/8/2021 +' Purpose : Verify that the user wants to cancel the current operation +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Unload(Cancel As Integer) + + Static intAttempt As Integer + + ' Allow the form to close on the third attempt, just in case the log + ' is stuck in active status for some reason. + If intAttempt > 2 Then Exit Sub + + ' Check to see if we have an active job running. + If Log.Active Then + If ConfirmCancel Then Log.Error eelCritical, "Canceled Operation", Me.Name & ".Form_Unload" + ' Either way, we want the log to complete first. + Cancel = True + intAttempt = intAttempt + 1 + End If + + ' Release the log console if we are closing the form + If Not Cancel Then Log.ReleaseConsole + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdOpenLogFile_Click +' Author : Adam Waller +' Date : 11/6/2020 +' Purpose : Open the log file +'--------------------------------------------------------------------------------------- +' +Private Sub cmdOpenLogFile_Click() + cmdClose.SetFocus + If FSO.FileExists(strLastLogFilePath) Then + ' (Note, parentheses are required for the path argument) + CreateObject("Shell.Application").Open (strLastLogFilePath) + End If +End Sub diff --git a/Version Control.accda.src/forms/frmVCSOptions.bas b/Version Control.accda.src/forms/frmVCSOptions.bas index d0597872..0fc7f107 100644 --- a/Version Control.accda.src/forms/frmVCSOptions.bas +++ b/Version Control.accda.src/forms/frmVCSOptions.bas @@ -3652,829 +3652,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -'--------------------------------------------------------------------------------------- -' Module : Form_frmOptions -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : NOTE - Options are dynamically loaded to the controls, and then saved -' : back to the class (and subsequently project) when the user clicks the -' : save and close button. Most options will not require event coding since -' : they are mapped to their appropriate option using the control name. -' : I.e. chkUseFastSave = Options.UseFastSave -'--------------------------------------------------------------------------------------- - -Option Compare Database -Option Explicit - -Private Enum eTableCol - etcName = 0 - etcType = 1 - etcHidden = 2 - etcSystem = 3 - etcOther = 4 - etcLocal = 5 - etcLinked = 6 -End Enum - -Private Enum eMapAction - emaClassToForm - emaFormToClass -End Enum - - -' Dictionary to stash database schemas while managing options. -Public DatabaseSchemas As Dictionary - - -'--------------------------------------------------------------------------------------- -' Procedure : chkTableShowHidden_Click -' Author : Adam Waller -' Date : 4/17/2020 -' Purpose : Update the list of tables -'--------------------------------------------------------------------------------------- -' -Private Sub chkTableShowHidden_Click() - RefreshTableDisplay -End Sub -Private Sub chkTableShowOther_Click() - RefreshTableDisplay -End Sub -Private Sub chkTableShowSystem_Click() - RefreshTableDisplay -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : chkUseGitIntegration_Click -' Author : Adam Waller -' Date : 11/25/2020 -' Purpose : Show the git integration page if using this option. -'--------------------------------------------------------------------------------------- -' -Private Sub chkUseGitIntegration_Click() - pgeGitIntegration.Visible = chkUseGitIntegration -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdAddDatabase_Click -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Add an external database connection -'--------------------------------------------------------------------------------------- -' -Private Sub cmdAddDatabase_Click() - DoCmd.OpenForm "frmVCSDatabase" -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdEditDatabase_Click -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Edit an existing database connection -'--------------------------------------------------------------------------------------- -' -Private Sub cmdEditDatabase_Click() - If Len(Nz(lstDatabases)) > 0 Then - ' Open the form as hidden, then load the properties - DoCmd.OpenForm "frmVCSDatabase", , , , , acHidden - With Form_frmVCSDatabase - .LoadSchema lstDatabases, Me.DatabaseSchemas(Nz(lstDatabases)) - .Visible = True - End With - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : lstDatabases_DblClick -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Shortcut to edit the selected database -'--------------------------------------------------------------------------------------- -' -Private Sub lstDatabases_DblClick(Cancel As Integer) - cmdEditDatabase_Click -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdDeleteDatabase_Click -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Delete a database connection -'--------------------------------------------------------------------------------------- -' -Private Sub cmdDeleteDatabase_Click() - Dim strName As String - strName = Nz(lstDatabases) - If Len(strName) = 0 Then - MsgBox2 "Select a connection to delete", , , vbExclamation - Else - With Me.DatabaseSchemas - If .Exists(strName) Then - If MsgBox2("Remove Connection?", "Are you sure you want to delete '" & strName & "'?", _ - "Click YES to remove or NO to cancel.", vbQuestion + vbYesNo) = vbYes Then - .Remove strName - RefreshSchemaList - End If - End If - End With - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : LoadSchemas -' Author : Adam Waller -' Date : 7/20/2023 -' Purpose : Load (or reload) the schemas from a dictionary object -'--------------------------------------------------------------------------------------- -' -Public Sub RefreshSchemaList() - - Dim varKey As Variant - - With lstDatabases - .RowSource = vbNullString - ' Add header row - .AddItem "Name;Description" - ' Update list from dictionary - For Each varKey In Me.DatabaseSchemas.Keys - .AddItem CStr(varKey) & ";" & Me.DatabaseSchemas(varKey)("Description") - Next varKey - End With - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdCancel_Click -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Cancel (close) the form. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdCancel_Click() - DoCmd.Close acForm, Me.Name -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdClearDefaults_Click -' Author : Adam Waller -' Date : 4/16/2020 -' Purpose : Clear the default and project settings. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdClearDefaults_Click() - Dim cDefaults As clsOptions - Set cDefaults = New clsOptions - cDefaults.SaveOptionsAsDefault - If MsgBox2("Apply to this Project?", _ - "The default options have been reset. Would you like these applied to this project as well?", _ - "Click 'Yes' to apply the default options, or 'No' to leave the current options.", _ - vbQuestion + vbYesNo, "Version Control System") = VbMsgBoxResult.vbYes Then - cmdRestoreDefaults_Click - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : LoadTableList -' Author : Adam Waller -' Date : 4/16/2020 -' Purpose : Load the list of tables in the current database, and merge in the list -' : of tables where we are opting to save data. -'--------------------------------------------------------------------------------------- -' -Private Sub LoadTableList() - - Dim varKey As Variant - Dim strFormat As String - Dim intFormat As eTableDataExportFormat - Dim strName As String - Dim dbs As DAO.Database - Dim rstTableData As DAO.Recordset - Dim rstSource As DAO.Recordset - Dim strSql As String - Dim lngFlags As Long - Dim lngType As Long - - ' Reset list of tables - Set dbs = CodeDb - dbs.Execute "DELETE FROM tblTableData;", dbFailOnError - - ' Open table to load records - Set rstTableData = dbs.OpenRecordset("SELECT * FROM tblTableData;", dbOpenDynaset) - - ' Get list of tables if we have a database file open. - If DatabaseFileOpen Then - - ' Note that Access SQL does not support bitwise "and" operator - ' (Also known as BAND in ADO) so we will check the bit flags in VBA instead. - strSql = _ - "SELECT o.Name, o.Type, o.Flags " & _ - "FROM MSysObjects AS o " & _ - "WHERE o.Type IN (1, 4, 6) " & _ - "ORDER BY o.Name;" - - Set rstSource = CurrentDb.OpenRecordset(strSql, dbOpenSnapshot) - With rstSource - Do While Not .EOF - ' Determine type of table - lngFlags = Nz(!Flags, 0) - lngType = Nz(!Type, 0) - If (lngFlags < 0) Or BitSet(lngFlags, 1) Then - ' Don't include read-only or deeply hidden system tables. - ' https://isladogs.co.uk/purpose-of-system-tables-2/index.html#TFE - Else - rstTableData.AddNew - rstTableData!TableName = Nz(!Name) - rstTableData!Flags = Nz(!Flags) - rstTableData!IsSystem = BitSet(lngFlags, 2) - rstTableData!IsHidden = BitSet(lngFlags, 8) - rstTableData!IsLocal = (lngType = 1) - ' Determine table icon - rstTableData!TableIcon = GetTableIcon(etcLinked) ' Default to linked table if no match. - If rstTableData!IsLocal Then rstTableData!TableIcon = GetTableIcon(etcLocal) - If rstTableData!IsSystem Then rstTableData!TableIcon = GetTableIcon(etcSystem) - rstTableData.Update - End If - .MoveNext - Loop - .Close - End With - End If - - ' Add in the list of saved tables, adding into the sorted location - If Not Options.TablesToExportData Is Nothing Then - ' Loop through each table in the saved table list - For Each varKey In Options.TablesToExportData.Keys - strName = CStr(varKey) - strFormat = Options.TablesToExportData.Item(varKey)("Format") - intFormat = Options.GetTableExportFormat(strFormat) - - With rstTableData - .FindFirst "[TableName]='" & Replace$(strName, "'", "''") & "'" - If .NoMatch Then - .AddNew - !TableName = strName - !TableIcon = GetTableIcon(etcOther) - !FormatType = intFormat - !IsOther = True - .Update - Else - .Edit - !FormatType = intFormat - .Update - End If - End With - Next varKey - End If - - ' Close recordset after adding records - rstTableData.Close - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : SaveTableList -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Save the list of tables that should have its data exported to options file. -'--------------------------------------------------------------------------------------- -' -Private Sub SaveTableList() - - Dim rstTableData As DAO.Recordset - Dim dTables As Dictionary - Dim dTable As Dictionary - - ' Save list of tables to export data - Set dTables = New Dictionary - dTables.CompareMode = TextCompare - - Set rstTableData = CodeDb.OpenRecordset( _ - "SELECT TableName, FormatType FROM tblTableData " & _ - "WHERE FormatType <> 0 ORDER BY TableName;", dbOpenForwardOnly) - With rstTableData - Do Until .EOF - Set dTable = New Dictionary - dTable.CompareMode = TextCompare - dTable("Format") = Options.GetTableExportFormatName(Nz(!FormatType, 0)) - dTables.Add Nz(!TableName), dTable - .MoveNext - Loop - .Close - End With - - Set Options.TablesToExportData = dTables - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : AddUpdateTableInList -' Author : Adam Waller -' Date : 4/21/2020 -' Purpose : Updates the a table in the collection, adding it if it does not exist. -'--------------------------------------------------------------------------------------- -' -Private Sub AddUpdateTableInList(strName As String, lngFormatType As eTableDataExportFormat, blnHidden As Boolean, blnSystem As Boolean, blnOther As Boolean, blnLocal As Boolean) - - Dim rstClone As DAO.Recordset - Dim rstActive As DAO.Recordset - - Set rstClone = Me.sfrmTableData.Form.RecordsetClone - Set rstActive = Me.sfrmTableData.Form.Recordset - - With rstActive - - ' Look for matching table name - rstClone.FindFirst "TableName='" & Replace$(strName, "'", "''") & "'" - If rstClone.NoMatch Then - ' Add new table to this list - Me.sfrmTableData.Form.AllowAdditions = True - .AddNew - !TableName = strName - !TableIcon = GetTableIcon(etcOther) - Else - .Bookmark = rstClone.Bookmark - .Edit - End If - - ' Update remaining fields - !FormatType = lngFormatType - !IsHidden = blnHidden - !IsSystem = blnSystem - !IsOther = blnOther - !IsLocal = blnLocal - .Update - Me.sfrmTableData.Form.AllowAdditions = False - End With - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : RefreshTableDisplay -' Author : Adam Waller -' Date : 4/17/2020 -' Purpose : Update the subform's display -'--------------------------------------------------------------------------------------- -' -Private Sub RefreshTableDisplay() - - Dim strFilter As String - Dim strOrderBy As String - - If Me.chkTableShowOther Then - strOrderBy = strOrderBy & ", IIf([IsOther], 0, 1)" - Else - strFilter = strFilter & " AND [IsOther] = 0" - End If - - If Me.chkTableShowSystem Then - strOrderBy = strOrderBy & ", IIf([IsSystem], 0, 1)" - Else - strFilter = strFilter & " AND [IsSystem] = 0" - End If - - If Me.chkTableShowHidden Then - strOrderBy = strOrderBy & ", IIf([IsHidden], 0, 1)" - Else - strFilter = strFilter & " AND [IsHidden] = 0" - End If - - strOrderBy = strOrderBy & ", IIf([IsLocal], 0, 1), [TableName]" - - If Len(strFilter) Then - strFilter = " WHERE " & Mid$(strFilter, 6) - End If - - If Len(strOrderBy) Then - strOrderBy = " ORDER BY " & Mid$(strOrderBy, 3) - End If - - Dim strSql As String - strSql = _ - "SELECT d.TableIcon, d.TableName, d.FormatType, d.IsHidden, d.IsSystem, d.IsOther, d.IsLocal " & _ - "FROM tblTableData AS d " & _ - strFilter & _ - strOrderBy - - Me.sfrmTableData.Form.RecordSource = strSql - - ' Update captions with counts - Me.lblTableShowHidden.Caption = GetCaptionWithCount("Show Hidden", "d.IsHidden = True AND d.IsSystem = " & chkTableShowSystem) - Me.lblTableShowSystem.Caption = GetCaptionWithCount("Show System", "d.IsSystem = True AND d.IsHidden = " & chkTableShowHidden) - Me.lblTableShowOther.Caption = GetCaptionWithCount("Show Other ", "d.IsOther = True") - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : GetCaptionWithCount -' Author : bclothier -' Date : 5/15/2023 -' Purpose : Provides caption with a count appended if non-zero. -'--------------------------------------------------------------------------------------- -' -Private Function GetCaptionWithCount(TemplateCaption As String, CountFilter As String) As String - Dim rs As DAO.Recordset - Set rs = CodeDb.OpenRecordset( _ - "SELECT COUNT(d.TableName) FROM tblTableData AS d WHERE " & CountFilter, dbOpenSnapshot) - If rs.EOF = False Then - If Nz(rs.Fields(0).Value, 0) Then - GetCaptionWithCount = TemplateCaption & " (" & rs.Fields(0).Value & ")" - Exit Function - End If - End If - GetCaptionWithCount = TemplateCaption -End Function - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdOpenInstallFolder_Click -' Author : Adam Waller -' Date : 7/6/2023 -' Purpose : Open the installation folder -'--------------------------------------------------------------------------------------- -' -Private Sub cmdOpenInstallFolder_Click() - Application.FollowHyperlink modInstall.GetInstallSettings.strInstallFolder -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdRestoreDefaults_Click -' Author : Adam Waller -' Date : 4/16/2020 -' Purpose : Restore the default options to this project. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdRestoreDefaults_Click() - Options.LoadDefaultOptions - MapControlsToOptions emaClassToForm - MsgBox2 "Default Options Restored", _ - "The system default options have been restored to this project.", _ - "Be sure to click Save and Close when you are finished making changes.", _ - vbInformation, "Version Control System" -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdSaveAndClose_Click -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Save and close the options dialog -'--------------------------------------------------------------------------------------- -' -Private Sub cmdSaveAndClose_Click() - - ' Make sure we actually have a file open - If Not DatabaseFileOpen Then - MsgBox2 "No Database File Open", _ - "You must have a database file open to save VCS options to a source folder.", _ - "Please open a database file before saving options for a project.", vbExclamation - Exit Sub - End If - - ' Save options and close. - MapControlsToOptions emaFormToClass - Options.SaveOptionsForProject - DoCmd.Close acForm, Me.Name - - ' Update main form if options changed. - If IsLoaded(acForm, "frmVCSMain", True) Then Form_frmVCSMain.Form_Load - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdSaveAsDefault_Click -' Author : Adam Waller -' Date : 4/16/2020 -' Purpose : Save current options as default for projects. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdSaveAsDefault_Click() - - Dim strPath As String - - ' Note that we can't save an absolute path as default, or we will potentially - ' create some major issues with source files being overwritten and lost. - strPath = Nz(txtExportFolder) - If strPath <> vbNullString Then - If InStr(1, strPath, "%dbName%", vbTextCompare) < 1 Then - MsgBox2 "Invalid Export Path for Default", _ - "If you specify an absolute or relative Export Path as a default option," & vbCrLf & _ - "you must include the %dbName% placeholder to keep the paths unique.", _ - "Please update the Export Path and try again.", vbExclamation - Exit Sub - End If - End If - - ' Load the options from the form and save as default - MapControlsToOptions emaFormToClass - Options.SaveOptionsAsDefault - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : Form_Load -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Load options for this project -'--------------------------------------------------------------------------------------- -' -Private Sub Form_Load() - - Dim intFormat As eTableDataExportFormat - Dim intSanitizeLevel As eSanitizeLevel - - MapControlsToOptions emaClassToForm - RefreshTableDisplay - RefreshSchemaList - - ' Load list of table data export formats - Dim frmTableData As Form_frmVCSTableData - Set frmTableData = Me.sfrmTableData.Form - With frmTableData.cboFormatType - .RowSource = vbNullString - For intFormat = eTableDataExportFormat.etdNoData To eTableDataExportFormat.[_Last] - .AddItem intFormat & ";""" & Options.GetTableExportFormatName(intFormat) & """", intFormat - Next intFormat - Me.cboFormatTypeForOther.RowSource = .RowSource - Me.cboFormatTypeForOther.RemoveItem etdNoData - End With - - ' Load general sanitize options - With Me.cboSanitizeLevel - .RowSource = vbNullString - For intSanitizeLevel = 0 To (eSanitizeLevel.[_Last] - 1) - .AddItem intSanitizeLevel & ";" & Options.GetSanitizeLevelName(intSanitizeLevel) - Next intSanitizeLevel - End With - - ' Load color sanitize options - With Me.cboSanitizeColors - .RowSource = vbNullString - For intSanitizeLevel = 0 To (eSanitizeLevel.[_Last] - 1) - .AddItem intSanitizeLevel & ";" & Options.GetSanitizeLevelName(intSanitizeLevel) - Next intSanitizeLevel - End With - - ' Make form resizable (helpful with table selection when many tables are listed) - MakeDialogResizable Me - - ' Set inital column sizing for table data - DoEvents - Form_frmVCSTableData.Form_Resize - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : MapControlsToOptions -' Author : Adam Waller -' Date : 4/14/2020 -' Purpose : Map the form controls to the options, performing the specified action. -'--------------------------------------------------------------------------------------- -' -Private Sub MapControlsToOptions(eAction As eMapAction) - - Dim pge As Access.Page - Dim ctl As Access.Control - Dim strKey As String - Dim dSettings As Dictionary - - ' Loop through each page - For Each pge In tabOptions.Pages - For Each ctl In pge.Controls - Select Case ctl.ControlType - Case Access.acCheckBox, Access.acTextBox, Access.acComboBox - strKey = Mid$(ctl.Name, 4) - If pge Is pgePrinterSettings Then - ' Export print options - If eAction = emaClassToForm Then - ctl = Options.ExportPrintSettings(strKey) - ElseIf eAction = emaFormToClass Then - Set dSettings = Options.ExportPrintSettings - dSettings(strKey) = CBool(ctl) - End If - ElseIf pge Is pgeGitIntegration Then - ' Saved in Git Settings - If eAction = emaClassToForm Then - ctl = Options.GitSettings(strKey) - ElseIf eAction = emaFormToClass Then - Set dSettings = Options.GitSettings - dSettings(strKey) = ctl.Value - End If - Else - Select Case ctl.Name - Case Me.chkTableShowHidden.Name, Me.chkTableShowSystem.Name, Me.chkTableShowOther.Name, _ - Me.cboFormatTypeForOther.Name, Me.txtOtherTableName.Name - ' Skip these exceptions. - Case Me.cboDiffTool.Name - ' This is saved on the computer profile (registry) - If eAction = emaClassToForm Then - ctl = Diff.ToolName - Else - Diff.ToolName = Nz(ctl) - End If - Case Else - ' Get option name from control name following prefix. - If eAction = emaClassToForm Then - ctl = CallByName(Options, strKey, VbGet) - ElseIf eAction = emaFormToClass Then - ' Check for any hooks on option change - OnOptionChange strKey, Nz(ctl.Value) - ' Set the option value - CallByName Options, strKey, VbLet, Nz(ctl.Value) - End If - End Select - End If - Case Access.acListBox - ' Special handling for lists - Case Else - ' Ignore other controls - End Select - Next ctl - Next - - ' Table list for selecting tables to save data. - If eAction = emaClassToForm Then - LoadTableList - ElseIf eAction = emaFormToClass Then - SaveTableList - End If - - ' Database schemas - If eAction = emaClassToForm Then - Set DatabaseSchemas = CloneDictionary(Options.SchemaExports) - ElseIf eAction = emaFormToClass Then - Set Options.SchemaExports = CloneDictionary(DatabaseSchemas) - End If - - ' Enable pages based on options. - chkUseGitIntegration_Click - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : OnOptionChange -' Author : Adam Waller -' Date : 11/9/2023 -' Purpose : A hook to run special code or processing when specific options are changed -' : from their existing values. Add any specific rules here. -'--------------------------------------------------------------------------------------- -' -Private Sub OnOptionChange(strName As String, varNewValue As Variant) - - Dim blnChanged As Boolean - - ' Determine if the option was changed - blnChanged = Not (CVar(CallByName(Options, strName, VbGet)) = varNewValue) - If Not blnChanged Then Exit Sub - - ' Define actual rules here - Select Case strName - - ' If a user turns on the option to split files - Case "SplitLayoutFromVBA" - If varNewValue = True Then - If Git.Installed Then - If Git.IsInsideRepository Then - ' Prompt user with suggestion - If MsgBox2("May I make a Suggestion?", _ - "This project appears to be within a Git repository. This add-in includes a special utility " & _ - "that can split the files (layout and VBA) while preserving this history of previous changes in BOTH files.", _ - "Would you like to see additional information on this from the wiki?", vbQuestion + vbYesNo) = vbYes Then - FollowHyperlink "https://github.com/joyfullservice/msaccess-vcs-addin/wiki/Split-Files" - End If - End If - End If - End If - - End Select - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdAddOtherTableData_Click -' Author : Adam Waller -' Date : 4/16/2020 -' Purpose : Select another table not used in the current database -'--------------------------------------------------------------------------------------- -' -Private Sub cmdAddOtherTableData_Click() - Dim strTable As String - If Nz(Me.cboFormatTypeForOther.Value, "No Data") = "No Data" Then - MsgBox2 "Please select format", "Select the format to save table data before adding the table to the list.", , vbInformation - Else - strTable = Nz(Me.txtOtherTableName.Value, vbNullString) - If strTable <> vbNullString Then - AddUpdateTableInList strTable, Nz(Me.cboFormatTypeForOther.Value), False, False, True, False - chkTableShowOther = True - RefreshTableDisplay - End If - End If -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdPrintSettingsOptions_Click -' Author : Adam Waller -' Date : 11/9/2020 -' Purpose : View advanced options for saving print settings. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdPrintSettingsOptions_Click() - With pgePrinterSettings - .Visible = True - .SetFocus - End With -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdUninstall_Click -' Author : Adam Kauffman -' Date : 5/25/2020 -' Purpose : Remove the add-in. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdUninstall_Click() - UninstallVCSAddin -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : txtExportFolder_BeforeUpdate -' Author : Adam Waller -' Date : 5/6/2021 -' Purpose : Make sure we have a valid entry, blank, absolute path, or relative path. -'--------------------------------------------------------------------------------------- -' -Private Sub txtExportFolder_BeforeUpdate(Cancel As Integer) - - Dim strPath As String - - strPath = Nz(txtExportFolder) - If strPath <> vbNullString Then - If (Left(strPath, 1) = PathSep) Or _ - (InStr(2, strPath, ":" & PathSep) > 0) Then - ' Looks like a valid path - Else - MsgBox2 "Invalid Export Folder", _ - "This does not appear to be a valid relative or absolute path.", _ - "Please see the wiki documentation for more detail and examples.", vbExclamation - Cancel = True - End If - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : GetTableIcon -' Author : Adam Waller & Indigo744 -' Date : 11/11/2020 -' Purpose : Get an icon depending on the type of table -'--------------------------------------------------------------------------------------- -' -Private Function GetTableIcon(ByRef lngColumn As eTableCol) As String - Select Case lngColumn - Case etcSystem - ' System tables - ' Uses symbol DOTTED SQUARE - ' http://www.fileformat.info/info/unicode/char/2b1a/index.htm - GetTableIcon = ChrW$(11034) - Case etcLocal - ' Local tables - ' Uses symbol SQUARED PLUS - ' http://www.fileformat.info/info/unicode/char/229e/index.htm - GetTableIcon = ChrW$(8862) - Case etcOther - ' "Other" tables - ' Uses symbol RIGHTWARDS ARROW WITH HOOK - ' http://www.fileformat.info/info/unicode/char/21aa/index.htm - GetTableIcon = ChrW$(8618) - Case Else - ' Anything else would be a linked table - ' Uses symbol EARTH GLOBE AMERICAS - ' https://www.fileformat.info/info/unicode/char/1f30e/index.htm - GetTableIcon = ChrW$(55356) & ChrW$(57102) - End Select -End Function +' See "frmVCSOptions.cls" \ No newline at end of file diff --git a/Version Control.accda.src/forms/frmVCSOptions.cls b/Version Control.accda.src/forms/frmVCSOptions.cls new file mode 100644 index 00000000..797d5e5f --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSOptions.cls @@ -0,0 +1,826 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Module : Form_frmOptions +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : NOTE - Options are dynamically loaded to the controls, and then saved +' : back to the class (and subsequently project) when the user clicks the +' : save and close button. Most options will not require event coding since +' : they are mapped to their appropriate option using the control name. +' : I.e. chkUseFastSave = Options.UseFastSave +'--------------------------------------------------------------------------------------- + +Option Compare Database +Option Explicit + +Private Enum eTableCol + etcName = 0 + etcType = 1 + etcHidden = 2 + etcSystem = 3 + etcOther = 4 + etcLocal = 5 + etcLinked = 6 +End Enum + +Private Enum eMapAction + emaClassToForm + emaFormToClass +End Enum + + +' Dictionary to stash database schemas while managing options. +Public DatabaseSchemas As Dictionary + + +'--------------------------------------------------------------------------------------- +' Procedure : chkTableShowHidden_Click +' Author : Adam Waller +' Date : 4/17/2020 +' Purpose : Update the list of tables +'--------------------------------------------------------------------------------------- +' +Private Sub chkTableShowHidden_Click() + RefreshTableDisplay +End Sub +Private Sub chkTableShowOther_Click() + RefreshTableDisplay +End Sub +Private Sub chkTableShowSystem_Click() + RefreshTableDisplay +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : chkUseGitIntegration_Click +' Author : Adam Waller +' Date : 11/25/2020 +' Purpose : Show the git integration page if using this option. +'--------------------------------------------------------------------------------------- +' +Private Sub chkUseGitIntegration_Click() + pgeGitIntegration.Visible = chkUseGitIntegration +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdAddDatabase_Click +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Add an external database connection +'--------------------------------------------------------------------------------------- +' +Private Sub cmdAddDatabase_Click() + DoCmd.OpenForm "frmVCSDatabase" +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdEditDatabase_Click +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Edit an existing database connection +'--------------------------------------------------------------------------------------- +' +Private Sub cmdEditDatabase_Click() + If Len(Nz(lstDatabases)) > 0 Then + ' Open the form as hidden, then load the properties + DoCmd.OpenForm "frmVCSDatabase", , , , , acHidden + With Form_frmVCSDatabase + .LoadSchema lstDatabases, Me.DatabaseSchemas(Nz(lstDatabases)) + .Visible = True + End With + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : lstDatabases_DblClick +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Shortcut to edit the selected database +'--------------------------------------------------------------------------------------- +' +Private Sub lstDatabases_DblClick(Cancel As Integer) + cmdEditDatabase_Click +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdDeleteDatabase_Click +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Delete a database connection +'--------------------------------------------------------------------------------------- +' +Private Sub cmdDeleteDatabase_Click() + Dim strName As String + strName = Nz(lstDatabases) + If Len(strName) = 0 Then + MsgBox2 "Select a connection to delete", , , vbExclamation + Else + With Me.DatabaseSchemas + If .Exists(strName) Then + If MsgBox2("Remove Connection?", "Are you sure you want to delete '" & strName & "'?", _ + "Click YES to remove or NO to cancel.", vbQuestion + vbYesNo) = vbYes Then + .Remove strName + RefreshSchemaList + End If + End If + End With + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : LoadSchemas +' Author : Adam Waller +' Date : 7/20/2023 +' Purpose : Load (or reload) the schemas from a dictionary object +'--------------------------------------------------------------------------------------- +' +Public Sub RefreshSchemaList() + + Dim varKey As Variant + + With lstDatabases + .RowSource = vbNullString + ' Add header row + .AddItem "Name;Description" + ' Update list from dictionary + For Each varKey In Me.DatabaseSchemas.Keys + .AddItem CStr(varKey) & ";" & Me.DatabaseSchemas(varKey)("Description") + Next varKey + End With + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdCancel_Click +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Cancel (close) the form. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdCancel_Click() + DoCmd.Close acForm, Me.Name +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdClearDefaults_Click +' Author : Adam Waller +' Date : 4/16/2020 +' Purpose : Clear the default and project settings. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdClearDefaults_Click() + Dim cDefaults As clsOptions + Set cDefaults = New clsOptions + cDefaults.SaveOptionsAsDefault + If MsgBox2("Apply to this Project?", _ + "The default options have been reset. Would you like these applied to this project as well?", _ + "Click 'Yes' to apply the default options, or 'No' to leave the current options.", _ + vbQuestion + vbYesNo, "Version Control System") = VbMsgBoxResult.vbYes Then + cmdRestoreDefaults_Click + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : LoadTableList +' Author : Adam Waller +' Date : 4/16/2020 +' Purpose : Load the list of tables in the current database, and merge in the list +' : of tables where we are opting to save data. +'--------------------------------------------------------------------------------------- +' +Private Sub LoadTableList() + + Dim varKey As Variant + Dim strFormat As String + Dim intFormat As eTableDataExportFormat + Dim strName As String + Dim dbs As DAO.Database + Dim rstTableData As DAO.Recordset + Dim rstSource As DAO.Recordset + Dim strSql As String + Dim lngFlags As Long + Dim lngType As Long + + ' Reset list of tables + Set dbs = CodeDb + dbs.Execute "DELETE FROM tblTableData;", dbFailOnError + + ' Open table to load records + Set rstTableData = dbs.OpenRecordset("SELECT * FROM tblTableData;", dbOpenDynaset) + + ' Get list of tables if we have a database file open. + If DatabaseFileOpen Then + + ' Note that Access SQL does not support bitwise "and" operator + ' (Also known as BAND in ADO) so we will check the bit flags in VBA instead. + strSql = _ + "SELECT o.Name, o.Type, o.Flags " & _ + "FROM MSysObjects AS o " & _ + "WHERE o.Type IN (1, 4, 6) " & _ + "ORDER BY o.Name;" + + Set rstSource = CurrentDb.OpenRecordset(strSql, dbOpenSnapshot) + With rstSource + Do While Not .EOF + ' Determine type of table + lngFlags = Nz(!Flags, 0) + lngType = Nz(!Type, 0) + If (lngFlags < 0) Or BitSet(lngFlags, 1) Then + ' Don't include read-only or deeply hidden system tables. + ' https://isladogs.co.uk/purpose-of-system-tables-2/index.html#TFE + Else + rstTableData.AddNew + rstTableData!TableName = Nz(!Name) + rstTableData!Flags = Nz(!Flags) + rstTableData!IsSystem = BitSet(lngFlags, 2) + rstTableData!IsHidden = BitSet(lngFlags, 8) + rstTableData!IsLocal = (lngType = 1) + ' Determine table icon + rstTableData!TableIcon = GetTableIcon(etcLinked) ' Default to linked table if no match. + If rstTableData!IsLocal Then rstTableData!TableIcon = GetTableIcon(etcLocal) + If rstTableData!IsSystem Then rstTableData!TableIcon = GetTableIcon(etcSystem) + rstTableData.Update + End If + .MoveNext + Loop + .Close + End With + End If + + ' Add in the list of saved tables, adding into the sorted location + If Not Options.TablesToExportData Is Nothing Then + ' Loop through each table in the saved table list + For Each varKey In Options.TablesToExportData.Keys + strName = CStr(varKey) + strFormat = Options.TablesToExportData.Item(varKey)("Format") + intFormat = Options.GetTableExportFormat(strFormat) + + With rstTableData + .FindFirst "[TableName]='" & Replace$(strName, "'", "''") & "'" + If .NoMatch Then + .AddNew + !TableName = strName + !TableIcon = GetTableIcon(etcOther) + !FormatType = intFormat + !IsOther = True + .Update + Else + .Edit + !FormatType = intFormat + .Update + End If + End With + Next varKey + End If + + ' Close recordset after adding records + rstTableData.Close + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : SaveTableList +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Save the list of tables that should have its data exported to options file. +'--------------------------------------------------------------------------------------- +' +Private Sub SaveTableList() + + Dim rstTableData As DAO.Recordset + Dim dTables As Dictionary + Dim dTable As Dictionary + + ' Save list of tables to export data + Set dTables = New Dictionary + dTables.CompareMode = TextCompare + + Set rstTableData = CodeDb.OpenRecordset( _ + "SELECT TableName, FormatType FROM tblTableData " & _ + "WHERE FormatType <> 0 ORDER BY TableName;", dbOpenForwardOnly) + With rstTableData + Do Until .EOF + Set dTable = New Dictionary + dTable.CompareMode = TextCompare + dTable("Format") = Options.GetTableExportFormatName(Nz(!FormatType, 0)) + dTables.Add Nz(!TableName), dTable + .MoveNext + Loop + .Close + End With + + Set Options.TablesToExportData = dTables + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : AddUpdateTableInList +' Author : Adam Waller +' Date : 4/21/2020 +' Purpose : Updates the a table in the collection, adding it if it does not exist. +'--------------------------------------------------------------------------------------- +' +Private Sub AddUpdateTableInList(strName As String, lngFormatType As eTableDataExportFormat, blnHidden As Boolean, blnSystem As Boolean, blnOther As Boolean, blnLocal As Boolean) + + Dim rstClone As DAO.Recordset + Dim rstActive As DAO.Recordset + + Set rstClone = Me.sfrmTableData.Form.RecordsetClone + Set rstActive = Me.sfrmTableData.Form.Recordset + + With rstActive + + ' Look for matching table name + rstClone.FindFirst "TableName='" & Replace$(strName, "'", "''") & "'" + If rstClone.NoMatch Then + ' Add new table to this list + Me.sfrmTableData.Form.AllowAdditions = True + .AddNew + !TableName = strName + !TableIcon = GetTableIcon(etcOther) + Else + .Bookmark = rstClone.Bookmark + .Edit + End If + + ' Update remaining fields + !FormatType = lngFormatType + !IsHidden = blnHidden + !IsSystem = blnSystem + !IsOther = blnOther + !IsLocal = blnLocal + .Update + Me.sfrmTableData.Form.AllowAdditions = False + End With + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : RefreshTableDisplay +' Author : Adam Waller +' Date : 4/17/2020 +' Purpose : Update the subform's display +'--------------------------------------------------------------------------------------- +' +Private Sub RefreshTableDisplay() + + Dim strFilter As String + Dim strOrderBy As String + + If Me.chkTableShowOther Then + strOrderBy = strOrderBy & ", IIf([IsOther], 0, 1)" + Else + strFilter = strFilter & " AND [IsOther] = 0" + End If + + If Me.chkTableShowSystem Then + strOrderBy = strOrderBy & ", IIf([IsSystem], 0, 1)" + Else + strFilter = strFilter & " AND [IsSystem] = 0" + End If + + If Me.chkTableShowHidden Then + strOrderBy = strOrderBy & ", IIf([IsHidden], 0, 1)" + Else + strFilter = strFilter & " AND [IsHidden] = 0" + End If + + strOrderBy = strOrderBy & ", IIf([IsLocal], 0, 1), [TableName]" + + If Len(strFilter) Then + strFilter = " WHERE " & Mid$(strFilter, 6) + End If + + If Len(strOrderBy) Then + strOrderBy = " ORDER BY " & Mid$(strOrderBy, 3) + End If + + Dim strSql As String + strSql = _ + "SELECT d.TableIcon, d.TableName, d.FormatType, d.IsHidden, d.IsSystem, d.IsOther, d.IsLocal " & _ + "FROM tblTableData AS d " & _ + strFilter & _ + strOrderBy + + Me.sfrmTableData.Form.RecordSource = strSql + + ' Update captions with counts + Me.lblTableShowHidden.Caption = GetCaptionWithCount("Show Hidden", "d.IsHidden = True AND d.IsSystem = " & chkTableShowSystem) + Me.lblTableShowSystem.Caption = GetCaptionWithCount("Show System", "d.IsSystem = True AND d.IsHidden = " & chkTableShowHidden) + Me.lblTableShowOther.Caption = GetCaptionWithCount("Show Other ", "d.IsOther = True") + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : GetCaptionWithCount +' Author : bclothier +' Date : 5/15/2023 +' Purpose : Provides caption with a count appended if non-zero. +'--------------------------------------------------------------------------------------- +' +Private Function GetCaptionWithCount(TemplateCaption As String, CountFilter As String) As String + Dim rs As DAO.Recordset + Set rs = CodeDb.OpenRecordset( _ + "SELECT COUNT(d.TableName) FROM tblTableData AS d WHERE " & CountFilter, dbOpenSnapshot) + If rs.EOF = False Then + If Nz(rs.Fields(0).Value, 0) Then + GetCaptionWithCount = TemplateCaption & " (" & rs.Fields(0).Value & ")" + Exit Function + End If + End If + GetCaptionWithCount = TemplateCaption +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdOpenInstallFolder_Click +' Author : Adam Waller +' Date : 7/6/2023 +' Purpose : Open the installation folder +'--------------------------------------------------------------------------------------- +' +Private Sub cmdOpenInstallFolder_Click() + Application.FollowHyperlink modInstall.GetInstallSettings.strInstallFolder +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdRestoreDefaults_Click +' Author : Adam Waller +' Date : 4/16/2020 +' Purpose : Restore the default options to this project. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdRestoreDefaults_Click() + Options.LoadDefaultOptions + MapControlsToOptions emaClassToForm + MsgBox2 "Default Options Restored", _ + "The system default options have been restored to this project.", _ + "Be sure to click Save and Close when you are finished making changes.", _ + vbInformation, "Version Control System" +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdSaveAndClose_Click +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Save and close the options dialog +'--------------------------------------------------------------------------------------- +' +Private Sub cmdSaveAndClose_Click() + + ' Make sure we actually have a file open + If Not DatabaseFileOpen Then + MsgBox2 "No Database File Open", _ + "You must have a database file open to save VCS options to a source folder.", _ + "Please open a database file before saving options for a project.", vbExclamation + Exit Sub + End If + + ' Save options and close. + MapControlsToOptions emaFormToClass + Options.SaveOptionsForProject + DoCmd.Close acForm, Me.Name + + ' Update main form if options changed. + If IsLoaded(acForm, "frmVCSMain", True) Then Form_frmVCSMain.Form_Load + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdSaveAsDefault_Click +' Author : Adam Waller +' Date : 4/16/2020 +' Purpose : Save current options as default for projects. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdSaveAsDefault_Click() + + Dim strPath As String + + ' Note that we can't save an absolute path as default, or we will potentially + ' create some major issues with source files being overwritten and lost. + strPath = Nz(txtExportFolder) + If strPath <> vbNullString Then + If InStr(1, strPath, "%dbName%", vbTextCompare) < 1 Then + MsgBox2 "Invalid Export Path for Default", _ + "If you specify an absolute or relative Export Path as a default option," & vbCrLf & _ + "you must include the %dbName% placeholder to keep the paths unique.", _ + "Please update the Export Path and try again.", vbExclamation + Exit Sub + End If + End If + + ' Load the options from the form and save as default + MapControlsToOptions emaFormToClass + Options.SaveOptionsAsDefault + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Form_Load +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Load options for this project +'--------------------------------------------------------------------------------------- +' +Private Sub Form_Load() + + Dim intFormat As eTableDataExportFormat + Dim intSanitizeLevel As eSanitizeLevel + + MapControlsToOptions emaClassToForm + RefreshTableDisplay + RefreshSchemaList + + ' Load list of table data export formats + Dim frmTableData As Form_frmVCSTableData + Set frmTableData = Me.sfrmTableData.Form + With frmTableData.cboFormatType + .RowSource = vbNullString + For intFormat = eTableDataExportFormat.etdNoData To eTableDataExportFormat.[_Last] + .AddItem intFormat & ";""" & Options.GetTableExportFormatName(intFormat) & """", intFormat + Next intFormat + Me.cboFormatTypeForOther.RowSource = .RowSource + Me.cboFormatTypeForOther.RemoveItem etdNoData + End With + + ' Load general sanitize options + With Me.cboSanitizeLevel + .RowSource = vbNullString + For intSanitizeLevel = 0 To (eSanitizeLevel.[_Last] - 1) + .AddItem intSanitizeLevel & ";" & Options.GetSanitizeLevelName(intSanitizeLevel) + Next intSanitizeLevel + End With + + ' Load color sanitize options + With Me.cboSanitizeColors + .RowSource = vbNullString + For intSanitizeLevel = 0 To (eSanitizeLevel.[_Last] - 1) + .AddItem intSanitizeLevel & ";" & Options.GetSanitizeLevelName(intSanitizeLevel) + Next intSanitizeLevel + End With + + ' Make form resizable (helpful with table selection when many tables are listed) + MakeDialogResizable Me + + ' Set inital column sizing for table data + DoEvents + Form_frmVCSTableData.Form_Resize + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : MapControlsToOptions +' Author : Adam Waller +' Date : 4/14/2020 +' Purpose : Map the form controls to the options, performing the specified action. +'--------------------------------------------------------------------------------------- +' +Private Sub MapControlsToOptions(eAction As eMapAction) + + Dim pge As Access.Page + Dim ctl As Access.Control + Dim strKey As String + Dim dSettings As Dictionary + + ' Loop through each page + For Each pge In tabOptions.Pages + For Each ctl In pge.Controls + Select Case ctl.ControlType + Case Access.acCheckBox, Access.acTextBox, Access.acComboBox + strKey = Mid$(ctl.Name, 4) + If pge Is pgePrinterSettings Then + ' Export print options + If eAction = emaClassToForm Then + ctl = Options.ExportPrintSettings(strKey) + ElseIf eAction = emaFormToClass Then + Set dSettings = Options.ExportPrintSettings + dSettings(strKey) = CBool(ctl) + End If + ElseIf pge Is pgeGitIntegration Then + ' Saved in Git Settings + If eAction = emaClassToForm Then + ctl = Options.GitSettings(strKey) + ElseIf eAction = emaFormToClass Then + Set dSettings = Options.GitSettings + dSettings(strKey) = ctl.Value + End If + Else + Select Case ctl.Name + Case Me.chkTableShowHidden.Name, Me.chkTableShowSystem.Name, Me.chkTableShowOther.Name, _ + Me.cboFormatTypeForOther.Name, Me.txtOtherTableName.Name + ' Skip these exceptions. + Case Me.cboDiffTool.Name + ' This is saved on the computer profile (registry) + If eAction = emaClassToForm Then + ctl = Diff.ToolName + Else + Diff.ToolName = Nz(ctl) + End If + Case Else + ' Get option name from control name following prefix. + If eAction = emaClassToForm Then + ctl = CallByName(Options, strKey, VbGet) + ElseIf eAction = emaFormToClass Then + ' Check for any hooks on option change + OnOptionChange strKey, Nz(ctl.Value) + ' Set the option value + CallByName Options, strKey, VbLet, Nz(ctl.Value) + End If + End Select + End If + Case Access.acListBox + ' Special handling for lists + Case Else + ' Ignore other controls + End Select + Next ctl + Next + + ' Table list for selecting tables to save data. + If eAction = emaClassToForm Then + LoadTableList + ElseIf eAction = emaFormToClass Then + SaveTableList + End If + + ' Database schemas + If eAction = emaClassToForm Then + Set DatabaseSchemas = CloneDictionary(Options.SchemaExports) + ElseIf eAction = emaFormToClass Then + Set Options.SchemaExports = CloneDictionary(DatabaseSchemas) + End If + + ' Enable pages based on options. + chkUseGitIntegration_Click + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : OnOptionChange +' Author : Adam Waller +' Date : 11/9/2023 +' Purpose : A hook to run special code or processing when specific options are changed +' : from their existing values. Add any specific rules here. +'--------------------------------------------------------------------------------------- +' +Private Sub OnOptionChange(strName As String, varNewValue As Variant) + + Dim blnChanged As Boolean + + ' Determine if the option was changed + blnChanged = Not (CVar(CallByName(Options, strName, VbGet)) = varNewValue) + If Not blnChanged Then Exit Sub + + ' Define actual rules here + Select Case strName + + ' If a user turns on the option to split files + Case "SplitLayoutFromVBA" + If varNewValue = True Then + If Git.Installed Then + If Git.IsInsideRepository Then + ' Prompt user with suggestion + If MsgBox2("May I make a Suggestion?", _ + "This project appears to be within a Git repository. This add-in includes a special utility " & _ + "that can split the files (layout and VBA) while preserving this history of previous changes in BOTH files.", _ + "Would you like to see additional information on this from the wiki?", vbQuestion + vbYesNo) = vbYes Then + FollowHyperlink "https://github.com/joyfullservice/msaccess-vcs-addin/wiki/Split-Files" + End If + End If + End If + End If + + End Select + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdAddOtherTableData_Click +' Author : Adam Waller +' Date : 4/16/2020 +' Purpose : Select another table not used in the current database +'--------------------------------------------------------------------------------------- +' +Private Sub cmdAddOtherTableData_Click() + Dim strTable As String + If Nz(Me.cboFormatTypeForOther.Value, "No Data") = "No Data" Then + MsgBox2 "Please select format", "Select the format to save table data before adding the table to the list.", , vbInformation + Else + strTable = Nz(Me.txtOtherTableName.Value, vbNullString) + If strTable <> vbNullString Then + AddUpdateTableInList strTable, Nz(Me.cboFormatTypeForOther.Value), False, False, True, False + chkTableShowOther = True + RefreshTableDisplay + End If + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdPrintSettingsOptions_Click +' Author : Adam Waller +' Date : 11/9/2020 +' Purpose : View advanced options for saving print settings. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdPrintSettingsOptions_Click() + With pgePrinterSettings + .Visible = True + .SetFocus + End With +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdUninstall_Click +' Author : Adam Kauffman +' Date : 5/25/2020 +' Purpose : Remove the add-in. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdUninstall_Click() + UninstallVCSAddin +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : txtExportFolder_BeforeUpdate +' Author : Adam Waller +' Date : 5/6/2021 +' Purpose : Make sure we have a valid entry, blank, absolute path, or relative path. +'--------------------------------------------------------------------------------------- +' +Private Sub txtExportFolder_BeforeUpdate(Cancel As Integer) + + Dim strPath As String + + strPath = Nz(txtExportFolder) + If strPath <> vbNullString Then + If (Left(strPath, 1) = PathSep) Or _ + (InStr(2, strPath, ":" & PathSep) > 0) Then + ' Looks like a valid path + Else + MsgBox2 "Invalid Export Folder", _ + "This does not appear to be a valid relative or absolute path.", _ + "Please see the wiki documentation for more detail and examples.", vbExclamation + Cancel = True + End If + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : GetTableIcon +' Author : Adam Waller & Indigo744 +' Date : 11/11/2020 +' Purpose : Get an icon depending on the type of table +'--------------------------------------------------------------------------------------- +' +Private Function GetTableIcon(ByRef lngColumn As eTableCol) As String + Select Case lngColumn + Case etcSystem + ' System tables + ' Uses symbol DOTTED SQUARE + ' http://www.fileformat.info/info/unicode/char/2b1a/index.htm + GetTableIcon = ChrW$(11034) + Case etcLocal + ' Local tables + ' Uses symbol SQUARED PLUS + ' http://www.fileformat.info/info/unicode/char/229e/index.htm + GetTableIcon = ChrW$(8862) + Case etcOther + ' "Other" tables + ' Uses symbol RIGHTWARDS ARROW WITH HOOK + ' http://www.fileformat.info/info/unicode/char/21aa/index.htm + GetTableIcon = ChrW$(8618) + Case Else + ' Anything else would be a linked table + ' Uses symbol EARTH GLOBE AMERICAS + ' https://www.fileformat.info/info/unicode/char/1f30e/index.htm + GetTableIcon = ChrW$(55356) & ChrW$(57102) + End Select +End Function diff --git a/Version Control.accda.src/forms/frmVCSSplitFiles.bas b/Version Control.accda.src/forms/frmVCSSplitFiles.bas index 892aab52..27cd2a45 100644 --- a/Version Control.accda.src/forms/frmVCSSplitFiles.bas +++ b/Version Control.accda.src/forms/frmVCSSplitFiles.bas @@ -908,152 +908,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Compare Database -Option Explicit - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdAddFormsAndReports_Click -' Author : Adam Waller -' Date : 11/9/2023 -' Purpose : Add the forms and reports source files for the project. Doing this -' : intelligently by only adding items that have a VBA code module. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdAddFormsAndReports_Click() - - Dim intType As AcObjectType - Dim cComponent As IDbComponent - Dim varKey As Variant - Dim strFile As String - Dim strPrefix As String - Dim cList As clsConcat - - ' Prepare class for new list - Set cList = New clsConcat - cList.AppendOnAdd = vbCrLf - - ' Process for forms and reports (2 to 3) - DoCmd.Hourglass True - For intType = acForm To acReport - - ' Get component type - If intType = acForm Then - Set cComponent = New clsDbForm - strPrefix = "Form_" - ElseIf intType = acReport Then - Set cComponent = New clsDbReport - strPrefix = "Report_" - End If - - ' Loop through files - For Each varKey In cComponent.GetFileList.Keys - strFile = SwapExtension(CStr(varKey), "cls") - ' Skip files that already exist - If Not FSO.FileExists(strFile) Then - ' Check for code module marker in source file - If InStr(1, ReadFile(CStr(varKey)), "CodeBehindForm") > 0 Then - ' Add to list of files to split - cList.Add CStr(varKey), "|", strFile - End If - End If - Next varKey - Next intType - DoCmd.Hourglass False - cmdSplitFiles.SetFocus - - ' See if we found any files to split. - If cList.Length > 0 Then - ' Replace existing content. - txtFileList = cList.GetStr - Else - MsgBox2 "No Relevant Files Found", _ - "Could not find any combined form or report source files that contained VBA modules", _ - , vbInformation - End If - -End Sub - - -'--------------------------------------------------------------------------------------- -' Procedure : cmdSplitFiles_Click -' Author : Adam Waller -' Date : 5/8/2023 -' Purpose : Start the action to split the files. -'--------------------------------------------------------------------------------------- -' -Private Sub cmdSplitFiles_Click() - - Dim varEntries As Variant - Dim varPaths As Variant - Dim strPaths() As String - Dim strNew() As String - Dim lngLine As Long - Dim strError As String - Dim strWorkingFolderBackup As String - - ' Get an array of entries - varEntries = Split(Nz(txtFileList), vbCrLf) - - ' Loop through lines, building arrays and validating each entry. - For lngLine = 0 To UBound(varEntries) - varPaths = Split(varEntries(lngLine), "|") - If UBound(varPaths) = 1 Then - ' Perform some validation on the entries - If Not FSO.FileExists(varPaths(0)) Then strError = "File not found: " & varPaths(0) - If FSO.FileExists(varPaths(1)) Then strError = "File already exists: " & varPaths(1) - If varPaths(0) = "c:\example\original.txt" Then strError = "Please use your own file list, not the example." - If varPaths(0) = varPaths(1) Then strError = "Cannot split to the same file name: " & varPaths(0) - ' Add to arrays of file paths - AddToArray strPaths, varPaths(0) - AddToArray strNew, varPaths(1) - Else - If Len(Trim(varEntries(lngLine))) = 0 Then - ' Ignore blank lines - Else - strError = "Expecting two file paths, separated by | character. See line: '" & varPaths(0) & "'" - End If - End If - If Len(strError) Then Exit For - Next lngLine - - ' Show validation error - If Len(strError) Then - MsgBox2 "Validation Failed", strError, "Please correct the problem to continue.", vbExclamation - Else - ' Proceed with the split after some validation - - ' Get folder from first file (just in case they are from a different location) - strWorkingFolderBackup = Git.WorkingFolder - Git.WorkingFolder = FSO.GetParentFolderName(strPaths(0)) - - ' Require clean branch with git installation - If Not Git.IsCleanBranch Then strError = "Cannot split files in Git when changes are present in the branch" - If Not Git.Installed Then strError = "Git must be installed to use this tool." - - ' Make sure we don't have any errors with the Git commands - If Len(strError) Then - MsgBox2 "Validation Failed", strError, "Please correct the problem to continue.", vbExclamation - Else - ' Split the files using git commands - DoCmd.Hourglass True - Git.SplitFilesWithHistory strPaths, strNew, txtCommitMessage - DoCmd.Hourglass False - - ' Show success message - MsgBox2 "Finished", "The operation is complete.", _ - "For additional details, please see `git.log` in the source folder.", vbInformation - - ' Clear existing list - txtFileList = vbNullString - End If - - ' Restore original working folder - Git.WorkingFolder = strWorkingFolderBackup - End If - -End Sub +' See "frmVCSSplitFiles.cls" \ No newline at end of file diff --git a/Version Control.accda.src/forms/frmVCSSplitFiles.cls b/Version Control.accda.src/forms/frmVCSSplitFiles.cls new file mode 100644 index 00000000..2373fd3d --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSSplitFiles.cls @@ -0,0 +1,149 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdAddFormsAndReports_Click +' Author : Adam Waller +' Date : 11/9/2023 +' Purpose : Add the forms and reports source files for the project. Doing this +' : intelligently by only adding items that have a VBA code module. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdAddFormsAndReports_Click() + + Dim intType As AcObjectType + Dim cComponent As IDbComponent + Dim varKey As Variant + Dim strFile As String + Dim strPrefix As String + Dim cList As clsConcat + + ' Prepare class for new list + Set cList = New clsConcat + cList.AppendOnAdd = vbCrLf + + ' Process for forms and reports (2 to 3) + DoCmd.Hourglass True + For intType = acForm To acReport + + ' Get component type + If intType = acForm Then + Set cComponent = New clsDbForm + strPrefix = "Form_" + ElseIf intType = acReport Then + Set cComponent = New clsDbReport + strPrefix = "Report_" + End If + + ' Loop through files + For Each varKey In cComponent.GetFileList.Keys + strFile = SwapExtension(CStr(varKey), "cls") + ' Skip files that already exist + If Not FSO.FileExists(strFile) Then + ' Check for code module marker in source file + If InStr(1, ReadFile(CStr(varKey)), "CodeBehindForm") > 0 Then + ' Add to list of files to split + cList.Add CStr(varKey), "|", strFile + End If + End If + Next varKey + Next intType + DoCmd.Hourglass False + cmdSplitFiles.SetFocus + + ' See if we found any files to split. + If cList.Length > 0 Then + ' Replace existing content. + txtFileList = cList.GetStr + Else + MsgBox2 "No Relevant Files Found", _ + "Could not find any combined form or report source files that contained VBA modules", _ + , vbInformation + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : cmdSplitFiles_Click +' Author : Adam Waller +' Date : 5/8/2023 +' Purpose : Start the action to split the files. +'--------------------------------------------------------------------------------------- +' +Private Sub cmdSplitFiles_Click() + + Dim varEntries As Variant + Dim varPaths As Variant + Dim strPaths() As String + Dim strNew() As String + Dim lngLine As Long + Dim strError As String + Dim strWorkingFolderBackup As String + + ' Get an array of entries + varEntries = Split(Nz(txtFileList), vbCrLf) + + ' Loop through lines, building arrays and validating each entry. + For lngLine = 0 To UBound(varEntries) + varPaths = Split(varEntries(lngLine), "|") + If UBound(varPaths) = 1 Then + ' Perform some validation on the entries + If Not FSO.FileExists(varPaths(0)) Then strError = "File not found: " & varPaths(0) + If FSO.FileExists(varPaths(1)) Then strError = "File already exists: " & varPaths(1) + If varPaths(0) = "c:\example\original.txt" Then strError = "Please use your own file list, not the example." + If varPaths(0) = varPaths(1) Then strError = "Cannot split to the same file name: " & varPaths(0) + ' Add to arrays of file paths + AddToArray strPaths, varPaths(0) + AddToArray strNew, varPaths(1) + Else + If Len(Trim(varEntries(lngLine))) = 0 Then + ' Ignore blank lines + Else + strError = "Expecting two file paths, separated by | character. See line: '" & varPaths(0) & "'" + End If + End If + If Len(strError) Then Exit For + Next lngLine + + ' Show validation error + If Len(strError) Then + MsgBox2 "Validation Failed", strError, "Please correct the problem to continue.", vbExclamation + Else + ' Proceed with the split after some validation + + ' Get folder from first file (just in case they are from a different location) + strWorkingFolderBackup = Git.WorkingFolder + Git.WorkingFolder = FSO.GetParentFolderName(strPaths(0)) + + ' Require clean branch with git installation + If Not Git.IsCleanBranch Then strError = "Cannot split files in Git when changes are present in the branch" + If Not Git.Installed Then strError = "Git must be installed to use this tool." + + ' Make sure we don't have any errors with the Git commands + If Len(strError) Then + MsgBox2 "Validation Failed", strError, "Please correct the problem to continue.", vbExclamation + Else + ' Split the files using git commands + DoCmd.Hourglass True + Git.SplitFilesWithHistory strPaths, strNew, txtCommitMessage + DoCmd.Hourglass False + + ' Show success message + MsgBox2 "Finished", "The operation is complete.", _ + "For additional details, please see `git.log` in the source folder.", vbInformation + + ' Clear existing list + txtFileList = vbNullString + End If + + ' Restore original working folder + Git.WorkingFolder = strWorkingFolderBackup + End If + +End Sub diff --git a/Version Control.accda.src/forms/frmVCSTableData.bas b/Version Control.accda.src/forms/frmVCSTableData.bas index 8177f06d..1e8ecd2e 100644 --- a/Version Control.accda.src/forms/frmVCSTableData.bas +++ b/Version Control.accda.src/forms/frmVCSTableData.bas @@ -287,17 +287,4 @@ Begin Form End End CodeBehindForm -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Compare Database -Option Explicit - - -Public Sub Form_Resize() - ScaleColumns Me, , Array(Me.txtTableIcon.Name, Me.cboFormatType.Name) - - ' Size to fit; don't rely on Access' saved settings to get this right. - Me.txtTableIcon.ColumnWidth = -2 -End Sub +' See "frmVCSTableData.cls" diff --git a/Version Control.accda.src/forms/frmVCSTableData.cls b/Version Control.accda.src/forms/frmVCSTableData.cls new file mode 100644 index 00000000..3d4215c8 --- /dev/null +++ b/Version Control.accda.src/forms/frmVCSTableData.cls @@ -0,0 +1,14 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + + +Public Sub Form_Resize() + ScaleColumns Me, , Array(Me.txtTableIcon.Name, Me.cboFormatType.Name) + + ' Size to fit; don't rely on Access' saved settings to get this right. + Me.txtTableIcon.ColumnWidth = -2 +End Sub diff --git a/Version Control.accda.src/modules/clsDbCommandBar.cls b/Version Control.accda.src/modules/clsDbCommandBar.cls new file mode 100644 index 00000000..b3bf79ad --- /dev/null +++ b/Version Control.accda.src/modules/clsDbCommandBar.cls @@ -0,0 +1,726 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "clsDbCommandBar" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Author : Adam Waller +' Date : 4/23/2020 +' Purpose : This class extends the IDbComponent class to perform the specific +' : operations required by this particular object type. +' : (I.e. The specific way you export or import this component.) +'--------------------------------------------------------------------------------------- +Option Compare Database +Option Explicit + +Private m_CommandBar As CommandBar +Private m_Items(True To False) As Dictionary +Private m_dItems As Dictionary + +Private Type udtThis + BarProperties As Collection + CtlProperties As Collection + dImages As Dictionary ' Dictionary of image objects used with this CommandBar +End Type +Private this As udtThis + +' This requires us to use all the public methods and properties of the implemented class +' which keeps all the component classes consistent in how they are used in the export +' and import process. The implemented functions should be kept private as they are called +' from the implementing class, not this class. +Implements IDbComponent + + +'--------------------------------------------------------------------------------------- +' Procedure : Export +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Export the individual database component (table, form, query, etc...) +'--------------------------------------------------------------------------------------- +' +Private Sub IDbComponent_Export(Optional strAlternatePath As String) + Dim strContent As String + strContent = GetSource + WriteFile strContent, Nz2(strAlternatePath, IDbComponent_SourceFile) + SaveImages + VCSIndex.Update Me, IIf(strAlternatePath = vbNullString, eatExport, eatAltExport), GetStringHash(strContent, True) +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : SaveImages +' Author : Adam Waller +' Date : 1/12/2024 +' Purpose : Saves the images for the menu bar +'--------------------------------------------------------------------------------------- +' +Private Sub SaveImages() + + Dim varPic As Variant + + ' Make sure we actually have images to save + If this.dImages Is Nothing Then Exit Sub + If this.dImages.Count = 0 Then Exit Sub + + ' Verify the first path, to make sure the folder exists + VerifyPath CStr(this.dImages.Keys(1)) + + Perf.OperationStart "Save CommandBar Images" + For Each varPic In this.dImages.Keys + ' Save the item image to a file + stdole.SavePicture this.dImages(varPic).Picture, varPic & "Picture.bmp" + ' Also save image mask + stdole.SavePicture this.dImages(varPic).Mask, varPic & "Mask.bmp" + Next varPic + Perf.OperationEnd + + ' After saving the images, we can clear the references + ' to the image objects + Set this.dImages = Nothing + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Import +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Import the individual database component from a file. +'--------------------------------------------------------------------------------------- +' +Private Sub IDbComponent_Import(strFile As String) + + Dim dBar As Dictionary + Dim strName As String + + If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next + + ' Only import files with the correct extension. + If Not strFile Like "*.json" Then Exit Sub + Set dBar = ReadJsonFile(strFile) + + ' Delete any existing bar with this name. + strName = GetObjectNameFromFileName(strFile) + Set m_CommandBar = GetExisting(strName) + If Not m_CommandBar Is Nothing Then + If m_CommandBar.BuiltIn Then + Log.Error eelError, "You cannot replace the existing built-in command bar: " & m_CommandBar.Name, ModuleName(Me) & ".Import" + Exit Sub + Else + ' Delete the command bar + m_CommandBar.Delete + Set m_CommandBar = Nothing + End If + End If + + ' Now, create a new command bar, and add controls to it. + Perf.OperationStart "Building CommandBar" + Set m_CommandBar = CommandBars.Add(strName, msoBarPopup, , False) + BuildControls dBar("Items"), m_CommandBar + Perf.OperationEnd + + ' Log any errors + CatchAny eelError, "Importing CommandBar " & strName, ModuleName(Me) & ".Import" + + ' Save to index + VCSIndex.Update Me, eatImport, GetDictionaryHash(GetDictionary) + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : BuildMenu +' Author : Adam Waller +' Date : 1/13/2024 +' Purpose : Recursive function to build the controls on the popup menu +'--------------------------------------------------------------------------------------- +' +Private Sub BuildControls(dParent As Dictionary, objItem As Object) + + Dim varProp As Variant + Dim varCtl As Variant + Dim dControl As Dictionary + Dim varValue As Variant + Dim varCtlProp As Variant + Dim colItems As Collection + Dim picItem As IPictureDisp + Dim strPath As String + + LogUnhandledErrors + On Error Resume Next + + If TypeOf objItem Is CommandBar Then + ' Set command bar properties + For Each varProp In dParent.Keys + Select Case varProp + Case "Controls", "Type" + ' Skip these + Case Else + CallByName objItem, varProp, VbLet, dParent(varProp) + If CatchAny(eelNoError, vbNullString) Then + Debug.Print "Could not set " & varProp & " on " & objItem.Name + End If + End Select + Next varProp + ' Now add any nested controls + If dParent.Exists("Controls") Then + For Each dControl In dParent("Controls") + If dControl("BuiltIn") Then + ' Insert built-in control + With objItem.Controls.Add(dControl("Type"), dControl("Id")) + .Visible = dControl("Visible") + End With + Else + ' Build the control ourselves + BuildControls dControl, objItem.Controls.Add(dControl("Type")) + End If + Next dControl + End If + ElseIf TypeOf objItem Is CommandBarControl Then + ' Set control properties + For Each varProp In dParent.Keys + Select Case varProp + Case "ImagePath", "Type" + ' Skip these + Case Else + CallByName objItem, varProp, VbLet, dParent(varProp) + If CatchAny(eelNoError, vbNullString) Then + Debug.Print "Could not set " & varProp & " on " & objItem.Caption + End If + End Select + Next varProp + If TypeOf objItem Is CommandBarPopup And dParent.Exists("Controls") Then + ' Add nested controls + For Each dControl In dParent("Controls") + BuildControls dControl, objItem.Controls.Add(dControl("Type")) + Next dControl + Else + ' Check for picture + If dParent.Exists("ImagePath") Then + ' Build out full path to main image (Picture) + strPath = GetPathFromRelative(dParent("ImagePath") & "Picture.bmp") + If FSO.FileExists(strPath) Then + Set picItem = stdole.LoadPicture(strPath) + objItem.Picture = picItem + End If + ' Build path to image mask (transparency) + strPath = GetPathFromRelative(dParent("ImagePath") & "Mask.bmp") + If FSO.FileExists(strPath) Then + Set picItem = stdole.LoadPicture(strPath) + objItem.Mask = picItem + End If + End If + End If + Else + ' Unsupported object type + Stop + End If + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : GetExisting +' Author : Adam Waller +' Date : 1/13/2024 +' Purpose : Returns any existing command bar by that name +'--------------------------------------------------------------------------------------- +' +Private Function GetExisting(strName As String) As CommandBar + LogUnhandledErrors + On Error Resume Next + Set GetExisting = CommandBars(strName) + If Err Then Err.Clear +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : GetSource +' Author : Adam Waller +' Date : 2/14/2022 +' Purpose : Return the full content that will be saved to the source file. +'--------------------------------------------------------------------------------------- +' +Private Function GetSource() As String + GetSource = BuildJsonFile(TypeName(Me), GetDictionary, "CommandBar") +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : GetDictionary +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return a dictionary object of project properties. +'--------------------------------------------------------------------------------------- +' +Private Function GetDictionary(Optional blnUseCache As Boolean = True) As Dictionary + Dim dParent As Dictionary + Set dParent = New Dictionary + Set this.dImages = New Dictionary + Set GetDictionary = BuildElementDictionary(dParent, m_CommandBar) +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : BuildElements +' Author : Adam Waller +' Date : 1/12/2024 +' Purpose : A recursive function to build out the dictionary elements representing +' : a CommandBar popup menu. +' : objItem may represent a CommandBar, or a CommandBarControl. +'--------------------------------------------------------------------------------------- +' +Private Function BuildElementDictionary(dParent As Dictionary, objItem As Object) As Dictionary + + Dim varProp As Variant + Dim varCtl As Variant + Dim varValue As Variant + Dim varCtlProp As Variant + Dim colItems As Collection + Dim picItem As IPictureDisp + Dim strPath As String + + LogUnhandledErrors + On Error Resume Next + + If TypeOf objItem Is CommandBar Then + ' Add command bar properties + For Each varProp In this.BarProperties + varValue = CallByName(objItem, varProp, VbGet) + If Not CatchAny(eelNoError, vbNullString) Then + dParent.Add varProp, varValue + End If + Next varProp + ' Now add any nested controls + Set colItems = New Collection + dParent.Add "Controls", BuildControlCollection(objItem.Controls) + ElseIf TypeOf objItem Is CommandBarControl Then + ' Add control properties + For Each varProp In this.CtlProperties + varValue = CallByName(objItem, varProp, VbGet) + If Not CatchAny(eelNoError, vbNullString) Then + dParent.Add varProp, varValue + End If + Next varProp + ' Save the ID for built-in items + If objItem.BuiltIn Then dParent.Add "Id", objItem.ID + If TypeOf objItem Is CommandBarPopup Then + ' Loop through nested controls + dParent.Add "Controls", BuildControlCollection(objItem.Controls) + Else + ' Check for picture + Set picItem = objItem.Picture + If Not picItem Is Nothing Then + strPath = GetImagePath(objItem) + ' Check path for possible duplicates (menu items with the same name) + If this.dImages.Exists(strPath) Then + ' Add a number to make the path unique. + strPath = strPath & this.dImages.Count & "_" + End If + ' Save reference to image objects to use when + ' exporting images to files. + this.dImages.Add strPath, objItem + ' Save path to images in element dictionary + dParent.Add "ImagePath", GetRelativePath(strPath) + End If + End If + Else + ' Unsupported object type + Stop + End If + + ' Return dictionary + Set BuildElementDictionary = dParent + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : BuildControlCollection +' Author : Adam Waller +' Date : 1/12/2024 +' Purpose : Return a collection of the command bar controls. +'--------------------------------------------------------------------------------------- +' +Private Function BuildControlCollection(ctls As CommandBarControls) As Collection + Dim ctl As CommandBarControl + Dim dItem As Dictionary + Set BuildControlCollection = New Collection + For Each ctl In ctls + Set dItem = New Dictionary + BuildControlCollection.Add BuildElementDictionary(dItem, ctl) + Next ctl +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : GetImagePath +' Author : Adam Waller +' Date : 1/12/2024 +' Purpose : Build a base path for the image files. (Image and mask) +'--------------------------------------------------------------------------------------- +' +Private Function GetImagePath(ctl As CommandBarControl) As String + + Dim objParent As Object + Dim ctlTest As Object + Dim strName As String + Dim strSegment As String + + On Error GoTo 0 + Set ctlTest = ctl + ' Walk up the parent objects to build a full path to the control. + ' (We are using a name path since the control IDs and indexes may change) + Do + If TypeOf ctlTest Is CommandBar Then + ' Don't include command bar name, since we are using a subfolder + ' to store images for each commmand bar. + strSegment = vbNullString + ElseIf TypeOf ctlTest Is CommandBarPopup Then + ' We already have the name for this item + strSegment = vbNullString + Else + ' Control item. (Use caption or ID) + strSegment = Nz2(MultiReplace(ctlTest.Caption, _ + "&", vbNullString, _ + "...", vbNullString) _ + , ctlTest.ID) + End If + If Len(strSegment) Then strName = strSegment & "_" & strName + If ctlTest.Parent Is Application Then + ' This is the top level + Exit Do + Else + ' Move up to parent object + Set ctlTest = ctlTest.Parent + End If + Loop + + ' Convert name to a filesafe name + GetImagePath = IDbComponent_BaseFolder & BuildPath2(GetSafeFileName(m_CommandBar.Name) & "_Images", GetSafeFileName(strName)) + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : Merge +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Merge the source file into the existing database, updating or replacing +' : any existing object. +'--------------------------------------------------------------------------------------- +' +Private Sub IDbComponent_Merge(strFile As String) + ' Import if file exists + If FSO.FileExists(strFile) Then + IDbComponent_Import strFile + Else + VCSIndex.Remove Me, strFile + End If +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : IDbComponent_MoveSource +' Author : Adam Waller +' Date : 9/10/2022 +' Purpose : Move the component's source file(s) from one folder to another +'--------------------------------------------------------------------------------------- +' +Private Sub IDbComponent_MoveSource(strFromFolder As String, strToFolder As String) + MoveFileIfExists strFromFolder & FSO.GetFileName(IDbComponent_SourceFile), strToFolder + MoveFolderIfExists strFromFolder & FSO.GetBaseName(IDbComponent_SourceFile), strToFolder +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : GetAllFromDB +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return a collection of class objects represented by this component type. +'--------------------------------------------------------------------------------------- +' +Private Function IDbComponent_GetAllFromDB(Optional blnModifiedOnly As Boolean = False) As Dictionary + + Dim cCmdBar As IDbComponent + Dim bar As CommandBar + Dim blnAdd As Boolean + + ' Build collection if not already cached + If m_Items(blnModifiedOnly) Is Nothing Then + ' Loop through command bars, looking for any custom ones. + Set m_Items(blnModifiedOnly) = New Dictionary + For Each bar In Application.CommandBars + If Not bar.BuiltIn Then + 'If bar.Name = "Query" Then + Set cCmdBar = New clsDbCommandBar + Set cCmdBar.DbObject = bar + blnAdd = True + If blnModifiedOnly Then blnAdd = cCmdBar.IsModified + If blnAdd Then m_Items(blnModifiedOnly).Add cCmdBar.SourceFile, cCmdBar + End If + Next bar + + End If + + ' Return cached collection + Set IDbComponent_GetAllFromDB = m_Items(blnModifiedOnly) + +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : GetFileList +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return a list of file names to import for this component type. +'--------------------------------------------------------------------------------------- +' +Private Function IDbComponent_GetFileList() As Dictionary + Set IDbComponent_GetFileList = New Dictionary + If FSO.FileExists(IDbComponent_SourceFile) Then IDbComponent_GetFileList.Add IDbComponent_SourceFile, vbNullString +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : IsModified +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Returns true if the object in the database has been modified since +' : the last export of the object. +'--------------------------------------------------------------------------------------- +' +Public Function IDbComponent_IsModified() As Boolean + IDbComponent_IsModified = VCSIndex.Item(Me).FileHash <> GetStringHash(GetSource, True) +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : DateModified +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : The date/time the object was modified. (If possible to retrieve) +' : If the modified date cannot be determined (such as application +' : properties) then this function will return 0. +'--------------------------------------------------------------------------------------- +' +Private Function IDbComponent_DateModified() As Date + IDbComponent_DateModified = 0 +End Function + + +'--------------------------------------------------------------------------------------- +' Procedure : Category +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return a category name for this type. (I.e. forms, queries, macros) +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_Category() As String + IDbComponent_Category = "CommandBars" +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : BaseFolder +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return the base folder for import/export of this component. +'--------------------------------------------------------------------------------------- +Private Property Get IDbComponent_BaseFolder() As String + IDbComponent_BaseFolder = Options.GetExportFolder & "menus" & PathSep +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : FileExtensions +' Author : Adam Waller +' Date : 12/1/2023 +' Purpose : A collection of the file extensions used in source files for this +' : component type. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_FileExtensions() As Collection + Set IDbComponent_FileExtensions = New Collection + IDbComponent_FileExtensions.Add "json" +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : Name +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return a name to reference the object for use in logs and screen output. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_Name() As String +' If m_Project Is Nothing Then Exit Property + IDbComponent_Name = m_CommandBar.Name +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : SourceFile +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return the full path of the source file for the current object. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_SourceFile() As String + IDbComponent_SourceFile = IDbComponent_BaseFolder & GetSafeFileName(m_CommandBar.Name) & ".json" +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : Count +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Return a count of how many items are in this category. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_Count(Optional blnModifiedOnly As Boolean = False) As Long + IDbComponent_Count = IDbComponent_GetAllFromDB(blnModifiedOnly).Count +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : QuickCount +' Author : Adam Waller +' Date : 6/14/2022 +' Purpose : Return a cached, non-iterative approximate count of database objects +' : for use with progress indicators when scanning for changes. Single file +' : objects like database properties can simply return 1. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_QuickCount() As Long + ' Probably 0 in most databases. We will have to iterate through the CommandBars + ' to check the .BuiltIn flag to get an actual count. + IDbComponent_QuickCount = 0 +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : ComponentType +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : The type of component represented by this class. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_ComponentType() As eDatabaseComponentType + IDbComponent_ComponentType = edbCommandBar +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : DbObject +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : This represents the database object we are dealing with. +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_DbObject() As Object + Set IDbComponent_DbObject = m_CommandBar +End Property +Private Property Set IDbComponent_DbObject(ByVal RHS As Object) + Set m_CommandBar = RHS +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : SingleFile +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Returns true if the export of all items is done as a single file instead +' : of individual files for each component. (I.e. properties, references) +'--------------------------------------------------------------------------------------- +' +Private Property Get IDbComponent_SingleFile() As Boolean + IDbComponent_SingleFile = False +End Property + + +'--------------------------------------------------------------------------------------- +' Procedure : Class_Initialize +' Author : Adam Waller +' Date : 5/17/2021 +' Purpose : Helps us know whether we have already counted the objects. +'--------------------------------------------------------------------------------------- +' +Private Sub Class_Initialize() + 'm_Count = -1 + + ' Set up property name lists + + ' CommandBar Properties + Set this.BarProperties = New Collection + With this.BarProperties + .Add "AdaptiveMenu" + .Add "Context" + .Add "Enabled" + .Add "Height" + .Add "Left" + .Add "Protection" + .Add "RowIndex" + .Add "Top" + .Add "Type" + .Add "Width" + End With + + ' CommmandBarControl Properties + Set this.CtlProperties = New Collection + With this.CtlProperties + .Add "BeginGroup" + .Add "BuiltIn" + .Add "Caption" + .Add "DescriptionText" + .Add "Enabled" + .Add "Height" + .Add "HelpContextId" + .Add "HelpFile" + .Add "IsPriorityDropped" + .Add "Left" + .Add "OLEUsage" + .Add "OnAction" + .Add "Parameter" + .Add "Priority" + .Add "Tag" + .Add "TooltipText" + .Add "Top" + .Add "Type" + .Add "Visible" + .Add "Width" + End With + +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Class_Terminate +' Author : Adam Waller +' Date : 1/13/2024 +' Purpose : Clear any object references +'--------------------------------------------------------------------------------------- +' +Private Sub Class_Terminate() + ' Clear the images dictionary, just in case it still has references + ' to the commandbar image objects. + Set this.dImages = Nothing +End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : Parent +' Author : Adam Waller +' Date : 4/24/2020 +' Purpose : Return a reference to this class as an IDbComponent. This allows you +' : to reference the public methods of the parent class without needing +' : to create a new class object. +'--------------------------------------------------------------------------------------- +' +Public Property Get Parent() As IDbComponent + Set Parent = Me +End Property diff --git a/Version Control.accda.src/modules/clsDbMacro.cls b/Version Control.accda.src/modules/clsDbMacro.cls index e27e415c..4956f753 100644 --- a/Version Control.accda.src/modules/clsDbMacro.cls +++ b/Version Control.accda.src/modules/clsDbMacro.cls @@ -59,7 +59,7 @@ Private Sub IDbComponent_Import(strFile As String) strName = GetObjectNameFromFileName(strFile) LoadComponentFromText acMacro, strName, strFile Set m_Macro = CurrentProject.AllMacros(strName) - VCSIndex.Update Me, eatImport + VCSIndex.Update Me, eatImport, GetFileHash(strFile) End Sub diff --git a/Version Control.accda.src/modules/clsDbQuery.cls b/Version Control.accda.src/modules/clsDbQuery.cls index 3d402773..986e7a30 100644 --- a/Version Control.accda.src/modules/clsDbQuery.cls +++ b/Version Control.accda.src/modules/clsDbQuery.cls @@ -107,7 +107,7 @@ Private Sub IDbComponent_Import(strFile As String) strQueryName = GetObjectNameFromFileName(strFile) LoadComponentFromText acQuery, strQueryName, strFile Set m_Query = CurrentData.AllQueries(strQueryName) - VCSIndex.Update Me, eatImport + VCSIndex.Update Me, eatImport, GetFileHash(strFile) ' In some cases, such as when a query contains a subquery, AND has been modified in the ' visual query designer, it may be imported incorrectly and unable to run. For these diff --git a/Version Control.accda.src/modules/clsDbTableDataMacro.cls b/Version Control.accda.src/modules/clsDbTableDataMacro.cls index dc2d79e4..8ebdc5cd 100644 --- a/Version Control.accda.src/modules/clsDbTableDataMacro.cls +++ b/Version Control.accda.src/modules/clsDbTableDataMacro.cls @@ -72,7 +72,7 @@ Private Sub IDbComponent_Import(strFile As String) ' Update index Set m_Table = CurrentData.AllTables(strName) - VCSIndex.Update Me, eatImport + VCSIndex.Update Me, eatImport, GetFileHash(strFile) End Sub diff --git a/Version Control.accda.src/modules/clsDbTableDef.cls b/Version Control.accda.src/modules/clsDbTableDef.cls index eac3d889..521b35b7 100644 --- a/Version Control.accda.src/modules/clsDbTableDef.cls +++ b/Version Control.accda.src/modules/clsDbTableDef.cls @@ -175,7 +175,7 @@ Private Sub IDbComponent_Import(strFile As String) ' Update index strName = GetObjectNameFromFileName(strFile) Set m_Table = CurrentData.AllTables(strName) - VCSIndex.Update Me, eatImport + VCSIndex.Update Me, eatImport, GetFileHash(strFile) End Sub @@ -583,6 +583,7 @@ Private Function ImportLinkedTable(strFile As String) As Boolean If tdf.Connect <> strConnect Then tdf.Connect = strConnect tdf.RefreshLink + CatchAny eelError, "Error refreshing link for " & tdf.Name, ModuleName(Me) & ".ImportLinkedTable" End If dbs.TableDefs.Refresh diff --git a/Version Control.accda.src/modules/clsOptions.cls b/Version Control.accda.src/modules/clsOptions.cls index ab61e8f6..1123aaa2 100644 --- a/Version Control.accda.src/modules/clsOptions.cls +++ b/Version Control.accda.src/modules/clsOptions.cls @@ -352,6 +352,12 @@ End Function ' Private Sub Upgrade(ByRef dOptions As Dictionary) + Dim varKey As Variant + Dim dItem As Dictionary + Dim varItems As Variant + Dim colItems As Collection + Dim varLine As Variant + ' 6/16/2021 ' Aggressive sanitize to sanitize levels If dOptions.Exists("AggressiveSanitize") Then @@ -381,6 +387,29 @@ Private Sub Upgrade(ByRef dOptions As Dictionary) End If End If + ' 1/9/2024 (4.0.31) + ' Use collection to store schema filter entries + If dOptions.Exists("SchemaExports") Then + If dOptions("SchemaExports").Count > 0 Then + For Each varKey In dOptions("SchemaExports").Keys + Set dItem = dOptions("SchemaExports").Item(varKey) + If dItem.Exists("Filter") Then + ' If this is a string value, upgrade it to a collection + If Not IsObject(dItem("Filter")) Then + Set colItems = New Collection + varItems = Split(dItem("Filter"), "\r\n") + Set dItem("Filter") = New Collection + ' Build collection items + For Each varLine In varItems + colItems.Add CStr(varLine) + Next varLine + Set dItem("Filter") = colItems + End If + End If + Next varKey + End If + End If + End Sub diff --git a/Version Control.accda.src/modules/clsSchemaMsSql.cls b/Version Control.accda.src/modules/clsSchemaMsSql.cls index 9c26cc88..1c3cbc37 100644 --- a/Version Control.accda.src/modules/clsSchemaMsSql.cls +++ b/Version Control.accda.src/modules/clsSchemaMsSql.cls @@ -34,7 +34,7 @@ Private Type udtThis blnUtcTime As Boolean strUserID As String strPassword As String - varFilters As Variant + colFilters As Collection End Type Private this As udtThis @@ -408,7 +408,7 @@ Private Sub ScanDatabaseObjects() strPath = this.strBaseFolder & strItem ' See if we pass the filter - If PassesSchemaFilter(strItem, this.varFilters) Then + If PassesSchemaFilter(strItem, this.colFilters) Then ' Add all objects to full collection m_AllItems.Add strItem, Nz(!last_modified) @@ -570,15 +570,15 @@ Private Sub IDbSchema_Initialize(dInstance As Scripting.IDictionary) Dim strFilter As String Dim varRules As Variant + Dim colRules As Collection - ' Build filters - strFilter = dNZ(dInstance, "Filter") - If Trim(Replace(strFilter, vbCrLf, vbNullString)) = vbNullString Then - ' Blank lines, or nothing defined - varRules = Array("*") + ' Map filter to collection + If dInstance.Exists("Filter") Then + ' Create collection of rules (we will skip comments and blank lines later) + Set colRules = dInstance("Filter") Else - ' Create array of rules (we will skip comments and blank lines later) - varRules = Split(strFilter, vbCrLf) + ' No rules defined + Set colRules = New Collection End If ' Set class values @@ -586,7 +586,7 @@ Private Sub IDbSchema_Initialize(dInstance As Scripting.IDictionary) .strName = dNZ(dInstance, "Name") .strConnect = dNZ(dInstance, "Connect") .strBaseFolder = Options.GetExportFolder & "databases\" & GetSafeFileName(.strName) & PathSep - .varFilters = varRules + Set .colFilters = colRules If dInstance.Exists("UtcDateTime") Then .blnUtcTime = dInstance("UtcDateTime") .blnInitialized = (Len(.strConnect)) End With diff --git a/Version Control.accda.src/modules/clsSchemaMySql.cls b/Version Control.accda.src/modules/clsSchemaMySql.cls index ef5813d8..6cf7c495 100644 --- a/Version Control.accda.src/modules/clsSchemaMySql.cls +++ b/Version Control.accda.src/modules/clsSchemaMySql.cls @@ -27,7 +27,7 @@ Private Type udtThis blnUtcTime As Boolean strUserID As String strPassword As String - varFilters As Variant + colFilters As Collection End Type Private this As udtThis @@ -274,7 +274,7 @@ Private Sub ScanDatabaseObjects() strHash = vbNullString ' See if we pass the filter - If PassesSchemaFilter(strItem, this.varFilters) Then + If PassesSchemaFilter(strItem, this.colFilters) Then ' Use modified date to match file, if possible. ' Some objects don't store a modified date, so use a hash for those. @@ -509,15 +509,15 @@ Private Sub IDbSchema_Initialize(dInstance As Scripting.IDictionary) Dim strFilter As String Dim varRules As Variant + Dim colRules As Collection - ' Build filters - strFilter = dNZ(dInstance, "Filter") - If Trim(Replace(strFilter, vbCrLf, vbNullString)) = vbNullString Then - ' Blank lines, or nothing defined - varRules = Array("*") + ' Map filter to collection + If dInstance.Exists("Filter") Then + ' Create collection of rules (we will skip comments and blank lines later) + Set colRules = dInstance("Filter") Else - ' Create array of rules (we will skip comments and blank lines later) - varRules = Split(strFilter, vbCrLf) + ' No rules defined + Set colRules = New Collection End If ' Set class values @@ -525,7 +525,7 @@ Private Sub IDbSchema_Initialize(dInstance As Scripting.IDictionary) .strName = dNZ(dInstance, "Name") .strConnect = dNZ(dInstance, "Connect") .strBaseFolder = Options.GetExportFolder & "databases\" & GetSafeFileName(.strName) & PathSep - .varFilters = varRules + Set .colFilters = colRules If dInstance.Exists("UtcDateTime") Then .blnUtcTime = dInstance("UtcDateTime") .blnInitialized = (Len(.strConnect)) End With diff --git a/Version Control.accda.src/modules/clsVCSIndex.cls b/Version Control.accda.src/modules/clsVCSIndex.cls index 7dbd0ae6..73b04f2f 100644 --- a/Version Control.accda.src/modules/clsVCSIndex.cls +++ b/Version Control.accda.src/modules/clsVCSIndex.cls @@ -194,7 +194,7 @@ End Sub '--------------------------------------------------------------------------------------- ' Public Function Update(cItem As IDbComponent, intAction As eIndexOperationType, _ - Optional strFileHash As String, Optional strOtherHash As String, Optional dteDateTime As Date) As Dictionary + strFileHash As String, Optional strOtherHash As String, Optional dteDateTime As Date) As Dictionary Dim dItem As Dictionary Dim strSection As String diff --git a/Version Control.accda.src/modules/modConstants.bas b/Version Control.accda.src/modules/modConstants.bas index 9839e6cc..12c7abf9 100644 --- a/Version Control.accda.src/modules/modConstants.bas +++ b/Version Control.accda.src/modules/modConstants.bas @@ -78,6 +78,7 @@ Public Enum eDatabaseComponentType edbVbeReference edbProject edbConnection + edbCommandBar ' Future implementation? 'edbLinkedTable 'edbFileProperty diff --git a/Version Control.accda.src/modules/modDatabase.bas b/Version Control.accda.src/modules/modDatabase.bas index 89ed41c7..15f261ed 100644 --- a/Version Control.accda.src/modules/modDatabase.bas +++ b/Version Control.accda.src/modules/modDatabase.bas @@ -552,8 +552,15 @@ Public Sub RunSubInCurrentProject(strSubName As String) ' Add project name so we can run it from the current datbase strCmd = "[" & CurrentVBProject.Name & "]." & strCmd - ' Run the sub - Application.Run strCmd + ' Check for add-in project name + If StrComp(CurrentVBProject.Name, GetAddInProject.Name, vbTextCompare) = 0 Then + ' Temporarily rename the add-in project so the sub runs in the current project. + GetAddInProject.Name = "MSAccessVCS-Lib" + Application.Run strCmd + GetAddInProject.Name = PROJECT_NAME + Else + Application.Run strCmd + End If End Sub diff --git a/Version Control.accda.src/modules/modFunctions.bas b/Version Control.accda.src/modules/modFunctions.bas index 12bcaeb0..832cf3eb 100644 --- a/Version Control.accda.src/modules/modFunctions.bas +++ b/Version Control.accda.src/modules/modFunctions.bas @@ -72,7 +72,11 @@ End Sub Public Sub MergeDictionary(ByRef dOriginal As Dictionary, ByVal dToAdd As Dictionary) Dim varKey As Variant For Each varKey In dToAdd.Keys - dOriginal(varKey) = dToAdd(varKey) + If IsObject(dToAdd(varKey)) Then + Set dOriginal(varKey) = dToAdd(varKey) + Else + dOriginal(varKey) = dToAdd(varKey) + End If Next varKey End Sub diff --git a/Version Control.accda.src/modules/modOrphaned.bas b/Version Control.accda.src/modules/modOrphaned.bas index e7d08068..5bb559c9 100644 --- a/Version Control.accda.src/modules/modOrphaned.bas +++ b/Version Control.accda.src/modules/modOrphaned.bas @@ -154,7 +154,4 @@ Private Sub CompareToIndex(cType As IDbComponent, strFilePath As String, dExtens End If End If - ' Handle any uncaught errors - CatchAny eelError, "Error removing orphaned objects.", ModuleName & ".RemoveOrphanedDatabaseObjects" - End Sub diff --git a/Version Control.accda.src/modules/modUnitTesting.bas b/Version Control.accda.src/modules/modUnitTesting.bas index 1a173a9b..59daa696 100644 --- a/Version Control.accda.src/modules/modUnitTesting.bas +++ b/Version Control.accda.src/modules/modUnitTesting.bas @@ -3,6 +3,8 @@ Option Compare Database Option Explicit Option Private Module +Private Const ModuleName As String = "modUnitTesting" + '@TestModule '@Folder("Tests") @@ -453,3 +455,35 @@ Public Sub TestSqlFormatter() .SelfTest End With End Sub + + +'--------------------------------------------------------------------------------------- +' Procedure : TestCatch +' Author : hecon5 +' Date : 10/20/2023 +' Purpose : Validates that Catch operates correctly and that LogUnhandledErrors +' : doesn't create an infinite loop whether or not log exists. +' : +' : To use, run normally, after loading options / other core dependancies. +' : Then Stop the code (in VBA IDE) and then run again. Stopping code execution +'--------------------------------------------------------------------------------------- +' +Public Sub TestCatch() + + ' Specifiying a Const FunctionName allows copy/paste code and having the wrong FunctionName + ' names if (when) they change. + Const FunctionName As String = ModuleName & ".CatchTest" + + On Error Resume Next ' Clear out any errors that may happen, and continue on when errors happen. + Err.Raise 24601, "Pre Log Test" + + ' This is the "standard" way of catching errors without losing them. + LogUnhandledErrors FunctionName + On Error Resume Next + + ' "Pretend" code tossing an error. + Err.Raise 24602, "Post Log Test" + ' Checking for any issues post code execution. + CatchAny eelError, "Catch Test Validation", FunctionName + +End Sub diff --git a/Version Control.accda.src/modules/modUtcConverter.bas b/Version Control.accda.src/modules/modUtcConverter.bas index 2e45c59e..827e47c1 100644 --- a/Version Control.accda.src/modules/modUtcConverter.bas +++ b/Version Control.accda.src/modules/modUtcConverter.bas @@ -806,7 +806,7 @@ End Function '--------------------------------------------------------------------------------------- -' Procedure : ConvTimeUTC2 +' Procedure : ConvTimeUTC ' Author : Adam Waller ' Date : 11/14/2023 ' Purpose : Attempt a higher performance conversion first, then fall back to RegEx. @@ -815,13 +815,15 @@ End Function Private Function ConvTimeUTC(ByRef InVal As String) As Date Dim varParts As Variant - Dim InValSeconds As String + Dim dblSeconds As Double + ' Check for standard ISO date format If InVal Like "##:##:##.###Z" Then - ' Use high-performance conversion to date + ' Use high-performance conversion from string to date varParts = Split(InVal, ":") - InValSeconds = Mid(varParts(2), 1, Len(varParts(2)) - 1) - ConvTimeUTC = TimeSerialDbl(varParts(0), varParts(1), InValSeconds) + ' Use Val() function to avoid regional decimal conversion issues + dblSeconds = Val(Mid(varParts(2), 1, Len(varParts(2)) - 1)) + ConvTimeUTC = TimeSerialDbl(varParts(0), varParts(1), dblSeconds) Else ' Fall back to slower RegEx function ConvTimeUTC = ConvTimeUTC2(InVal) @@ -830,6 +832,13 @@ Private Function ConvTimeUTC(ByRef InVal As String) As Date End Function +'--------------------------------------------------------------------------------------- +' Procedure : ConvTimeUTC2 +' Author : Adam Waller +' Date : 1/10/2024 +' Purpose : Fallback date conversion using RegEx to parse ISO8601 dates +'--------------------------------------------------------------------------------------- +' Private Function ConvTimeUTC2(ByRef InVal As String) As Date Dim dblHours As Double @@ -866,7 +875,8 @@ Private Function ConvTimeUTC2(ByRef InVal As String) As Date If Not (IsEmpty(.SubMatches(3)) Or IsEmpty(.SubMatches(5)) Or NzEmpty(.SubMatches(3), ISO8601UTCTimeZone) = ISO8601UTCTimeZone) Then _ dblMinutes = dblMinutes - CDbl(NzEmpty(.SubMatches(3), vbNullString) & NzEmpty(.SubMatches(5), vbNullString)) - dblSeconds = CDbl(NzEmpty(.SubMatches(2), vbNullString)) + ' Use Val() function to avoid regional decimal conversion issues + dblSeconds = Val(NzEmpty(.SubMatches(2), vbNullString)) End With ConvTimeUTC2 = TimeSerialDbl(dblHours, dblMinutes, dblSeconds) diff --git a/Version Control.accda.src/modules/modVCSUtility.bas b/Version Control.accda.src/modules/modVCSUtility.bas index 53456cd8..a254f294 100644 --- a/Version Control.accda.src/modules/modVCSUtility.bas +++ b/Version Control.accda.src/modules/modVCSUtility.bas @@ -57,6 +57,7 @@ Public Function GetContainers(Optional intFilter As eContainerFilter = ecfAllObj .Add New clsDbVbeForm .Add New clsDbProjProperty .Add New clsDbSavedSpec + '.Add New clsDbCommandBar If blnADP Then ' Some types of objects only exist in ADP projects .Add New clsAdpFunction @@ -172,6 +173,7 @@ Public Function GetComponentClass(intType As eDatabaseComponentType) As IDbCompo Case edbVbeForm: Set cls = New clsDbVbeForm Case edbVbeProject: Set cls = New clsDbVbeProject Case edbVbeReference: Set cls = New clsDbVbeReference + Case edbCommandBar: Set cls = New clsDbCommandBar Case Else ' No match, return nothing End Select Set GetComponentClass = cls @@ -1198,26 +1200,32 @@ End Function ' : rule in order. Last matching rule will apply to the object. '--------------------------------------------------------------------------------------- ' -Public Function PassesSchemaFilter(strItem As String, varFilterArray As Variant) As Boolean +Public Function PassesSchemaFilter(strItem As String, colFilters As Collection) As Boolean Dim blnPass As Boolean - Dim lngRule As Long + Dim varRule As Variant Dim strRule As String - ' Loop through rules - For lngRule = 0 To UBound(varFilterArray) - strRule = Trim(varFilterArray(lngRule)) - Select Case Left(strRule, 1) - Case "#", vbNullString - ' Ignore comments and blank lines - Case "!" - ' Negative rule (do not include) - If strItem Like Mid(strRule, 2) Then blnPass = False - Case Else - ' Positive rule - If strItem Like strRule Then blnPass = True - End Select - Next lngRule + If colFilters Is Nothing Then + blnPass = True + ElseIf colFilters.Count = 0 Then + blnPass = True + Else + ' Loop through rules + For Each varRule In colFilters + strRule = CStr(varRule) + Select Case Left$(strRule, 1) + Case "#", vbNullString + ' Ignore comments and blank lines + Case "!" + ' Negative rule (do not include) + If strItem Like Mid$(strRule, 2) Then blnPass = False + Case Else + ' Positive rule + If strItem Like strRule Then blnPass = True + End Select + Next varRule + End If ' Return final result PassesSchemaFilter = blnPass diff --git a/Version Control.accda.src/vbe-project.json b/Version Control.accda.src/vbe-project.json index 4469bc19..bb94c824 100644 --- a/Version Control.accda.src/vbe-project.json +++ b/Version Control.accda.src/vbe-project.json @@ -5,7 +5,7 @@ }, "Items": { "Name": "MSAccessVCS", - "Description": "Version 4.0.22 deployed on 9/20/2023", + "Description": "Version 4.0.30 deployed on 12/15/2023", "FileName": "Version Control.accda", "HelpFile": "", "HelpContextId": 0, diff --git a/Version Control.accda.src/vcs-options.json b/Version Control.accda.src/vcs-options.json index ad7e3a09..39f23877 100644 --- a/Version Control.accda.src/vcs-options.json +++ b/Version Control.accda.src/vcs-options.json @@ -1,6 +1,6 @@ { "Info": { - "AddinVersion": "4.0.30", + "AddinVersion": "4.0.31", "AccessVersion": "14.0 32-bit" }, "Options": { @@ -36,7 +36,7 @@ "FormatSQL": true, "ForceImportOriginalQuerySQL": false, "SaveTableSQL": true, - "SplitLayoutFromVBA": false, + "SplitLayoutFromVBA": true, "StripPublishOption": true, "SanitizeColors": 3, "SanitizeLevel": 2, @@ -54,7 +54,7 @@ "RunBeforeExport": "", "RunAfterExport": "", "RunBeforeBuild": "", - "RunAfterBuild": "", + "RunAfterBuild": "AfterBuild", "RunBeforeMerge": "", "RunAfterMerge": "", "ShowVCSLegacy": true,