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,