wizards/source/access2base/Control.xba | 44 ++++++----- wizards/source/access2base/DoCmd.xba | 12 --- wizards/source/access2base/Form.xba | 106 ++++++++++++++++++---------- wizards/source/access2base/Methods.xba | 42 ++++++++--- wizards/source/access2base/OptionGroup.xba | 1 wizards/source/access2base/SubForm.xba | 28 ++++--- wizards/source/access2base/UtilProperty.xba | 30 ++++++- 7 files changed, 167 insertions(+), 96 deletions(-)
New commits: commit 9ae261c124f935d94b66a5a0e5c815af958b49c4 Author: Jean-Pierre Ledure <[email protected]> Date: Sun Apr 22 14:20:58 2018 +0200 Access2Base - Support of forms collections In LO forms as known in the Base UI may have more than 1 main forms, all belonging to a forms collection. MSAccess does not have that feature. So far, only forms with 1 main form - from far the majority of cases - were fully supported by Access2Base. For other forms, the exploration of controls in additional main forms was not implemented. Current limitation: some form properties (e.g. RecordSource) are still limited to the firt member of the forms collection. diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba index ca3e887e2f06..0af21171fdcb 100644 --- a/wizards/source/access2base/Control.xba +++ b/wizards/source/access2base/Control.xba @@ -21,6 +21,7 @@ Private _ParentType As String ' One of CTLPARENTISxxxx constants Private _Shortcut As String Private _Name As String Private _FormComponent As Object ' com.sun.star.text.TextDocument +Private _MainForm As String ' To be propagated to all subcontrols Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure Private _DbEntry As Integer Private _ControlType As Integer @@ -41,6 +42,7 @@ Private Sub Class_Initialize() _Shortcut = "" _Name = "" Set _FormComponent = Nothing + _MainForm = "" _DocEntry = -1 _DbEntry = -1 _ThisProperties = Array() @@ -795,27 +797,30 @@ Dim j As Integer, oView As Object If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound End Select - ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name) - Set ocControl.ControlModel = ControlModel.getByName(ocControl._Name) - ocControl._ImplementationName = ocControl.ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? - ocControl._FormComponent = ParentComponent - If Utils._hasUNOProperty(ocControl.ControlModel, "ClassId") Then ocControl._ClassId = ocControl.ControlModel.ClassId - ' Complex bypass to find View of grid subcontrols ! - If Not IsNull(ControlView) Then ' Anticipate absence of ControlView in grid controls when edit mode - For i = 0 to ControlView.getCount() - 1 - Set oView = ControlView.GetByIndex(i) - If Not IsNull(oView) Then - If oView.getModel.Name = ocControl._Name Then - Set ocControl.ControlView = oView - Exit For + With ocControl + ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) + Set .ControlModel = ControlModel.getByName(._Name) + ._ImplementationName = .ControlModel.ColumnServiceName ' getImplementationName aborts for subcontrols !? + ._FormComponent = ParentComponent + ._MainForm = _MainForm + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + ' Complex bypass to find View of grid subcontrols ! + If Not IsNull(ControlView) Then ' Anticipate absence of ControlView in grid controls when edit mode + For i = 0 to ControlView.getCount() - 1 + Set oView = ControlView.GetByIndex(i) + If Not IsNull(oView) Then + If oView.getModel.Name = ._Name Then + Set .ControlView = oView + Exit For + End If End If - End If - Next i - End If + Next i + End If - ocControl._Initialize() - ocControl._DocEntry = _DocEntry - ocControl._DbEntry = _DbEntry + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With Set Controls = ocControl Exit_Function: @@ -1509,6 +1514,7 @@ Dim oControlEvents As Object, sEventName As String Set .DatabaseForm = ControlModel ._Name = _Name ._Shortcut = _Shortcut & ".Form" + ._MainForm = _MainForm .ParentComponent = _FormComponent ._DocEntry = _DocEntry ._DbEntry = _DbEntry diff --git a/wizards/source/access2base/DoCmd.xba b/wizards/source/access2base/DoCmd.xba index 2f2e0ae89e5d..b51629be9c3f 100644 --- a/wizards/source/access2base/DoCmd.xba +++ b/wizards/source/access2base/DoCmd.xba @@ -1139,18 +1139,6 @@ Dim sFilter As String, oForm As Object, oFormsCollection As Object Else sFilter = "(" & pvFilterName & ") And (" & pvWhereCondition & ")" End If - Set oFormsCollection = oOpenForm.DrawPage.Forms - If oFormsCollection.Count = 0 Then - Set oForm = Nothing - ElseIf oFormsCollection.hasByName("MainForm") Then - Set oForm = oFormsCollection.getByName("MainForm") - ElseIf oFormsCollection.hasByName("Form") Then - Set oForm = oFormsCollection.getByName("Form") - ElseIf oFormsCollection.hasByName(ofForm._Name) Then - Set oForm = oFormsCollection.getByName(ofForm._Name) - Else - Goto Trace_Error - End If If Not IsNull(oForm) Then If sFilter <> "" Then oForm.Filter = oDatabase._ReplaceSquareBrackets(sFilter) diff --git a/wizards/source/access2base/Form.xba b/wizards/source/access2base/Form.xba index 27c3d4a93133..c0a4bd8b793a 100644 --- a/wizards/source/access2base/Form.xba +++ b/wizards/source/access2base/Form.xba @@ -19,11 +19,13 @@ Private _Shortcut As String Private _Name As String Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure Private _DbEntry As Integer +Private _MainForms As Variant Private _IsLoaded As Boolean Private _OpenArgs As Variant Private _OrderBy As String Public Component As Object ' com.sun.star.text.TextDocument Public ContainerWindow As Object ' (No name) +Public FormsCollection As Object ' com.sun.star.form.OFormsCollection Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) REM ----------------------------------------------------------------------------------------------------------------------- @@ -35,11 +37,13 @@ Private Sub Class_Initialize() _Name = "" _DocEntry = -1 _DbEntry = -1 + _MainForms = Array() _IsLoaded = False _OpenArgs = "" _OrderBy = "" Set Component = Nothing Set ContainerWindow = Nothing + Set FormsCollection = Nothing Set DatabaseForm = Nothing End Sub ' Constructor @@ -377,7 +381,7 @@ Dim ogGroup As Object If IsMissing(pvGroupName) Then Call _TraceArguments() If _ErrorHandler() Then On Local Error Goto Error_Function - Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, Component, DatabaseForm) + Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISFORM, Component, FormsCollection) If Not IsNull(ogGroup) Then ogGroup._DocEntry = _DocEntry ogGroup._DbEntry = _DbEntry @@ -482,16 +486,20 @@ Public Function Controls(Optional ByVal pvIndex As Variant) As Variant If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Form.Controls") -Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer +Dim ocControl As Variant, iControlCount As Integer Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String -Dim j As Integer +Dim j As Integer, iCount As Integer, sName As String, iAddCount As Integer +Dim oDatabaseForm As Object, iCtlCount As Integer Set ocControl = Nothing If Not IsLoaded Then Goto Trace_Error_NotOpen - Set ocControl = New Control - ocControl._ParentType = CTLPARENTISFORM - sParentShortcut = _Shortcut - If IsNull(DatabaseForm) Then iControlCount = 0 Else iControlCount = DatabaseForm.getCount() + 'Count number of controls thru the forms collection + iControlCount = 0 + iCount = FormsCollection.Count + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then iControlCount = iControlCount + oDatabaseForm.getCount() + Next i If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object Set oCounter = New Collect @@ -507,36 +515,62 @@ Dim j As Integer ' Start building the ocControl object ' Determine exact name - sControls() = DatabaseForm.getElementNames() - + + sName = "" Select Case VarType(pvIndex) Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal If pvIndex < 0 Or pvIndex > iControlCount - 1 Then Goto Trace_Error_Index - ocControl._Name = sControls(pvIndex) + iAddCount = 0 + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + iCtlCount = oDatabaseForm.getCount() + If pvIndex >= iAddCount And pvIndex <= iAddcount + iCtlCount - 1 Then + sName = oDatabaseForm.ElementNames(pvIndex - iAddCount) + Exit For + End If + iAddCount = iAddcount +iCtlCount + End If + Next i Case vbString ' Check control name validity (non case sensitive) - bFound = False sIndex = UCase(Utils._Trim(pvIndex)) - For i = 0 To iControlCount - 1 - If UCase(sControls(i)) = sIndex Then - bFound = True - Exit For + bFound = False + For i = 0 To iCount - 1 + If i = 0 Then Set oDatabaseForm = DatabaseForm Else Set oDatabaseForm = FormsCollection.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + sControls() = oDatabaseForm.getElementNames() + For j = 0 To UBound(sControls) + If UCase(sControls(j)) = sIndex Then + sName = sControls(j) + bFound = True + Exit For + End If + Next j + If bFound Then Exit For End If Next i - If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound + If Not bFound Then Goto Trace_NotFound End Select - ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name) - Set ocControl.ControlModel = DatabaseForm.getByName(ocControl._Name) - ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() - ocControl._FormComponent = Component - If Utils._hasUNOProperty(ocControl.ControlModel, "ClassId") Then ocControl._ClassId = ocControl.ControlModel.ClassId - If ocControl._ClassId > 0 And ocControl._ClassId <> acHiddenControl Then - Set ocControl.ControlView = Component.CurrentController.getControl(ocControl.ControlModel) - End If + 'Initialize a new Control object + Set ocControl = New Control + With ocControl + ._ParentType = CTLPARENTISFORM + ._Name = sName + ._Shortcut = _Shortcut & "!" & Utils._Surround(sName) + If IsNull(oDatabaseForm) Then ._MainForm = "" Else ._MainForm = oDatabaseForm.Name + Set .ControlModel = oDatabaseForm.getByName(sName) + ._ImplementationName = .ControlModel.getImplementationName() + ._FormComponent = Component + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + If ._ClassId > 0 And ._ClassId <> acHiddenControl Then + Set .ControlView = Component.CurrentController.getControl(.ControlModel) + End If - ocControl._Initialize() - ocControl._DocEntry = _DocEntry - ocControl._DbEntry = _DbEntry + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With Set Controls = ocControl Exit_Function: @@ -736,6 +770,7 @@ REM ---------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- +REM ----------------------------------------------------------------------------------------------------------------------- Private Function _GetListener(ByVal psProperty As String) As String ' Return the X...Listener corresponding with the property in argument @@ -766,7 +801,7 @@ REM ---------------------------------------------------------------------------- Public Sub _Initialize(psName As String) ' Set pointers to UNO objects -Dim oDoc As Object, oFormsCollection As Object, oDatabase As Object +Dim oDoc As Object, oDatabase As Object If _ErrorHandler() Then On Local Error Goto Trace_Error _Name = psName _Shortcut = "Forms!" & Utils._Surround(psName) @@ -776,17 +811,14 @@ Dim oDoc As Object, oFormsCollection As Object, oDatabase As Object Case DBCONNECTBASE If Not IsNull(Component.CurrentController) Then ' A form opened then closed afterwards keeps a Component attribute Set ContainerWindow = Component.CurrentController.Frame.ContainerWindow - Set oFormsCollection = Component.getDrawPage.Forms - If oFormsCollection.Count = 0 Then + Set FormsCollection = Component.getDrawPage.Forms + If FormsCollection.Count = 0 Then Set DatabaseForm = Nothing - ElseIf oFormsCollection.hasByName("MainForm") Then - Set DatabaseForm = oFormsCollection.getByName("MainForm") - ElseIf oFormsCollection.hasByName("Form") Then - Set DatabaseForm = oFormsCollection.getByName("Form") - ElseIf oFormsCollection.hasByName(_Name) Then - Set DatabaseForm = oFormsCollection.getByName(_Name) Else - Goto Trace_Internal_Error + 'Only first member of the collection can be reached with A2B + 'Compliant with MSAccess which has 1 datasource by form, while LO might have many + _MainForms = FormsCollection.ElementNames() + Set DatabaseForm = FormsCollection.getByIndex(0) End If End If Case DBCONNECTFORM diff --git a/wizards/source/access2base/Methods.xba b/wizards/source/access2base/Methods.xba index 9afac28fc08f..de7f8d382337 100644 --- a/wizards/source/access2base/Methods.xba +++ b/wizards/source/access2base/Methods.xba @@ -200,7 +200,7 @@ REM ---------------------------------------------------------------------------- Public Function _OptionGroup(ByVal pvGroupName As Variant _ , ByVal psParentType As String _ , poComponent As Object _ - , poDatabaseForm As Object _ + , poParent As Object _ ) As Variant ' Return either an error or an object of type OPTIONGROUP based on its name @@ -213,24 +213,48 @@ Public Function _OptionGroup(ByVal pvGroupName As Variant _ Dim ogGroup As Variant, i As Integer, j As Integer, bFound As Boolean Dim vOptionButtons() As Variant, sGroupName As String Dim lXY() As Long, iIndex() As Integer ' Two indexes X-Y coordinates -Dim oView As Object +Dim oView As Object, oDatabaseForm As Object, vControls As Variant Const cstPixels = 10 ' Tolerance on coordinates when drawed approximately + bFound = False - For i = 0 To poDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? - poDatabaseForm.getGroup(i, vOptionButtons, sGroupName) - If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then - bFound = True - Exit For - End If - Next i + Select Case psParentType + Case CTLPARENTISFORM + 'poParent is a forms collection, find the appropriate database form + For i = 0 To poParent.Count - 1 + Set oDatabaseForm = poParent.getByIndex(i) + If Not IsNull(oDatabaseForm) Then + For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + oDatabaseForm.getGroup(j, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For + End If + Next j + If bFound Then Exit For + End If + If bFound Then Exit For + Next i + Case CTLPARENTISSUBFORM + 'poParent is already a database form + Set oDatabaseForm = poParent + For j = 0 To oDatabaseForm.GroupCount - 1 ' Does a group with the right name exist ? + oDatabaseForm.getGroup(j, vOptionButtons, sGroupName) + If UCase(sGroupName) = UCase(Utils._Trim(pvGroupName)) Then + bFound = True + Exit For + End If + Next j + End Select If bFound Then + ogGroup = New Optiongroup ogGroup._Name = sGroupName ogGroup._ButtonsGroup = vOptionButtons ogGroup._Count = UBound(vOptionButtons) + 1 ogGroup._ParentType = psParentType + ogGroup._MainForm = oDatabaseForm.Name Set ogGroup._ParentComponent = poComponent ReDim lXY(1, ogGroup._Count - 1) diff --git a/wizards/source/access2base/OptionGroup.xba b/wizards/source/access2base/OptionGroup.xba index 180591ae5b76..7690607b6f1a 100644 --- a/wizards/source/access2base/OptionGroup.xba +++ b/wizards/source/access2base/OptionGroup.xba @@ -18,6 +18,7 @@ Private _Type As String ' Must be FORM Private _Name As String Private _ParentType As String Private _ParentComponent As Object +Private _MainForm As String Private _DocEntry As Integer Private _DbEntry As Integer Private _ButtonsGroup() As Variant diff --git a/wizards/source/access2base/SubForm.xba b/wizards/source/access2base/SubForm.xba index bead65c95248..f34d3de4035c 100644 --- a/wizards/source/access2base/SubForm.xba +++ b/wizards/source/access2base/SubForm.xba @@ -17,6 +17,7 @@ REM ---------------------------------------------------------------------------- Private _Type As String ' Must be SUBFORM Private _Shortcut As String Private _Name As String +Private _MainForm As String Private _DocEntry As Integer Private _DbEntry As Integer Private _OrderBy As String @@ -30,6 +31,7 @@ Private Sub Class_Initialize() _Type = OBJSUBFORM _Shortcut = "" _Name = "" + _MainForm = "" _DocEntry = -1 _DbEntry = -1 _OrderBy = "" @@ -409,18 +411,20 @@ Dim j As Integer If bFound Then ocControl._Name = sControls(i) Else Goto Trace_NotFound End Select - ocControl._Shortcut = sParentShortcut & "!" & Utils._Surround(ocControl._Name) - Set ocControl.ControlModel = DatabaseForm.getByName(ocControl._Name) - ocControl._ImplementationName = ocControl.ControlModel.getImplementationName() - ocControl._FormComponent = ParentComponent - If Utils._hasUNOProperty(ocControl.ControlModel, "ClassId") Then ocControl._ClassId = ocControl.ControlModel.ClassId - If ocControl._ClassId > 0 And ocControl._ClassId <> acHiddenControl Then - Set ocControl.ControlView = ParentComponent.CurrentController.getControl(ocControl.ControlModel) - End If - - ocControl._Initialize() - ocControl._DocEntry = _DocEntry - ocControl._DbEntry = _DbEntry + With ocControl + ._Shortcut = sParentShortcut & "!" & Utils._Surround(._Name) + Set .ControlModel = DatabaseForm.getByName(._Name) + ._ImplementationName = .ControlModel.getImplementationName() + ._FormComponent = ParentComponent + If Utils._hasUNOProperty(.ControlModel, "ClassId") Then ._ClassId = .ControlModel.ClassId + If ._ClassId > 0 And ._ClassId <> acHiddenControl Then + Set .ControlView = ParentComponent.CurrentController.getControl(.ControlModel) + End If + + ._Initialize() + ._DocEntry = _DocEntry + ._DbEntry = _DbEntry + End With Set Controls = ocControl Exit_Function: diff --git a/wizards/source/access2base/UtilProperty.xba b/wizards/source/access2base/UtilProperty.xba index e17b10374441..55f3d9f2e5ef 100644 --- a/wizards/source/access2base/UtilProperty.xba +++ b/wizards/source/access2base/UtilProperty.xba @@ -25,11 +25,13 @@ REM ============================================================================ ' PropValuesToStr rewritten and addition of StrToPropValues ' Bug corrected on date values ' Addition of support of 2-dimensional arrays +' Support of empty arrays to allow JSON conversions '********************************************************************** Option Explicit Private Const cstHEADER = "### PROPERTYVALUES ###" +Private Const cstEMPTYARRAY = "### EMPTY ARRAY ###" REM ======================================================================================================================= Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvValue As Variant) As com.sun.star.beans.PropertyValue @@ -38,15 +40,27 @@ Public Function _MakePropertyValue(ByVal Optional psName As String, Optional pvV Dim oPropertyValue As New com.sun.star.beans.PropertyValue If Not IsMissing(psName) Then oPropertyValue.Name = psName - If Not IsMissing(pvValue) Then - ' Date BASIC variables give error. Change them to strings - If VarType(pvValue) = vbDate Then oPropertyValue.Value = Utils._CStr(pvValue, False) Else oPropertyValue.Value = pvValue - End If + If Not IsMissing(pvValue) Then oPropertyValue.Value = _CheckPropertyValue(pvValue) _MakePropertyValue() = oPropertyValue End Function ' _MakePropertyValue V1.3.0 REM ======================================================================================================================= +Public Function _CheckPropertyValue(ByRef pvValue As Variant) As Variant +' Date BASIC variables give error. Change them to strings +' Empty arrays should be replaced by cstEMPTYARRAY + + If VarType(pvValue) = vbDate Then + _CheckPropertyValue = Utils._CStr(pvValue, False) + ElseIf IsArray(pvValue) Then + If UBound(pvValue, 1) < LBound(pvValue, 1) Then _CheckPropertyValue = cstEMPTYARRAY Else _CheckPropertyValue = pvValue + Else + _CheckPropertyValue = pvValue + End If + +End Function ' _CheckPropertyValue + +REM ======================================================================================================================= Public Function _NumPropertyValues(ByRef pvPropertyValuesArray As Variant) As Integer ' Return the number of PropertyValue's in an array. ' Parameters: @@ -101,7 +115,9 @@ Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Varia If iPropIndex >= 0 Then vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript vValue = vProp.Value ' get the value from the PropertyValue - If IsArray(vValue) Then + If VarType(vValue) = vbString Then + If vValue = cstEMPTYARRAY Then _GetPropertyValue() = Array() Else _GetPropertyValue() = vValue + ElseIf IsArray(vValue) Then If IsArray(vValue(0)) Then ' Array of arrays vMatrix = Array() ReDim vMatrix(0 To UBound(vValue), 0 To UBound(vValue(0))) @@ -120,7 +136,7 @@ Dim iPropIndex As Integer, vProp As Variant, vValue As Variant, vMatrix As Varia Else If IsMissing(pvDefaultValue) Then pvDefaultValue = Null _GetPropertyValue() = pvDefaultValue - EndIf + EndIf End Function ' _GetPropertyValue V1.3.0 @@ -134,7 +150,7 @@ Dim iPropIndex As Integer, vProp As Variant, iNumProperties As Integer If iPropIndex >= 0 Then ' Found, the PropertyValue is already in the array. Just modify its value. vProp = pvPropertyValuesArray(iPropIndex) ' access array subscript - vProp.Value = pvValue ' set the property value. + vProp.Value = _CheckPropertyValue(pvValue) ' set the property value. pvPropertyValuesArray(iPropIndex) = vProp ' put it back into array Else ' Not found, the array contains no PropertyValue with this name. Append new element to array. _______________________________________________ Libreoffice-commits mailing list [email protected] https://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
