REM ======================================================================================================================= REM === The Access2Base library is a part of the LibreOffice project. === REM === Full documentation is available on http://www.access2base.com === REM ======================================================================================================================= Option Compatible Option ClassModule Option Explicit REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be SUBFORM Private _Shortcut As String Private _Name As String Private _DocEntry As Integer Private _DbEntry As Integer Private _OrderBy As String Public ParentComponent As Object ' com.sun.star.text.TextDocument Public DatabaseForm As Object ' com.sun.star.form.component.DataForm and com.sun.star.sdb.ResultSet (a.o.) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJSUBFORM _Shortcut = "" _Name = "" _DocEntry = -1 _DbEntry = -1 _OrderBy = "" Set ParentComponent = Nothing Set DatabaseForm = Nothing End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Terminate() On Local Error Resume Next Call Class_Initialize() End Sub ' Destructor REM ----------------------------------------------------------------------------------------------------------------------- Public Sub Dispose() Call Class_Terminate() End Sub ' Explicit destructor REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS GET/LET/SET PROPERTIES --- REM ----------------------------------------------------------------------------------------------------------------------- Property Get AllowAdditions() As Variant AllowAdditions = _PropertyGet("AllowAdditions") End Property ' AllowAdditions (get) Property Let AllowAdditions(ByVal pvValue As Variant) Call _PropertySet("AllowAdditions", pvValue) End Property ' AllowAdditions (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get AllowDeletions() As Variant AllowDeletions = _PropertyGet("AllowDeletions") End Property ' AllowDeletions (get) Property Let AllowDeletions(ByVal pvValue As Variant) Call _PropertySet("AllowDeletions", pvValue) End Property ' AllowDeletions (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get AllowEdits() As Variant AllowEdits = _PropertyGet("AllowEdits") End Property ' AllowEdits (get) Property Let AllowEdits(ByVal pvValue As Variant) Call _PropertySet("AllowEdits", pvValue) End Property ' AllowEdits (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get CurrentRecord() As Variant CurrentRecord = _PropertyGet("CurrentRecord") End Property ' CurrentRecord (get) Property Let CurrentRecord(ByVal pvValue As Variant) Call _PropertySet("CurrentRecord", pvValue) End Property ' CurrentRecord (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Filter() As Variant Filter = _PropertyGet("Filter") End Property ' Filter (get) Property Let Filter(ByVal pvValue As Variant) Call _PropertySet("Filter", pvValue) End Property ' Filter (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FilterOn() As Variant FilterOn = _PropertyGet("FilterOn") End Property ' FilterOn (get) Property Let FilterOn(ByVal pvValue As Variant) Call _PropertySet("FilterOn", pvValue) End Property ' FilterOn (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get LinkChildFields(ByVal Optional pvIndex As Variant) As Variant If IsMissing(pvIndex) Then LinkChildFields = _PropertyGet("LinkChildFields") Else LinkChildFields = _PropertyGet("LinkChildFields", pvIndex) End Property ' LinkChildFields (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get LinkMasterFields(ByVal Optional pvIndex As Variant) As Variant If IsMissing(pvIndex) Then LinkMasterFields = _PropertyGet("LinkMasterFields") Else LinkMasterFields = _PropertyGet("LinkMasterFields", pvIndex) End Property ' LinkMasterFields (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Name() As String Name = _PropertyGet("Name") End Property ' Name (get) Public Function pName() As String ' For compatibility with < V0.9.0 pName = _PropertyGet("Name") End Function ' pName (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String ObjectType = _PropertyGet("ObjectType") End Property ' ObjectType (get) REM ----------------------------------------------------------------------------------------------------------------------- Public Function OptionGroup(ByVal Optional pvGroupName As Variant) As Variant ' Return either an error or an object of type OPTIONGROUP based on its name Const cstThisSub = "SubForm.OptionGroup" Dim ogGroup As Object Utils._SetCalledSub(cstThisSub) If IsMissing(pvGroupName) Then Call _TraceArguments() If _ErrorHandler() Then On Local Error Goto Error_Function Set ogGroup = _OptionGroup(pvGroupName, CTLPARENTISSUBFORM, ParentComponent, DatabaseForm) If Not IsNull(ogGroup) Then ogGroup._DocEntry = _DocEntry ogGroup._DbEntry = _DbEntry End If Set OptionGroup = ogGroup Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' OptionGroup V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Property Get OrderBy() As Variant OrderBy = _PropertyGet("OrderBy") End Property ' OrderBy (get) V1.2.0 Property Let OrderBy(ByVal pvValue As Variant) Call _PropertySet("OrderBy", pvValue) End Property ' OrderBy (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OrderByOn() As Variant OrderByOn = _PropertyGet("OrderByOn") End Property ' OrderByOn (get) V1.2.0 Property Let OrderByOn(ByVal pvValue As Variant) Call _PropertySet("OrderByOn", pvValue) End Property ' OrderByOn (set) REM ----------------------------------------------------------------------------------------------------------------------- Public Function Parent() As Object Utils._SetCalledSub("SubForm.getParent") On Error Goto Error_Function Set Parent = PropertiesGet._ParentObject(_Shortcut) Exit_Function: Utils._ResetCalledSub("SubForm.getParent") Exit Function Error_Function: TraceError(TRACEABORT, Err, "SubForm.getParent", Erl) Set Parent = Nothing GoTo Exit_Function End Function ' Parent REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant ' Return ' a Collection object if pvIndex absent ' a Property object otherwise Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vPropertiesList = _PropertiesList() sObject = Utils._PCase(_Type) If IsMissing(pvIndex) Then vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Exit_Function: Set Properties = vProperty Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Property Get Recordset() As Object Recordset = _PropertyGet("Recordset") End Property ' Recordset (get) V0.9.5 REM ----------------------------------------------------------------------------------------------------------------------- Property Get RecordSource() As Variant RecordSource = _PropertyGet("RecordSource") End Property ' RecordSource (get) Property Let RecordSource(ByVal pvValue As Variant) Call _PropertySet("RecordSource", pvValue) End Property ' RecordSource (set) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Function Controls(Optional ByVal pvIndex As Variant) As Variant ' Return a Control object with name or index = pvIndex If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("SubForm.Controls") Dim ocControl As Variant, sParentShortcut As String, iControlCount As Integer Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String Dim j As Integer Set ocControl = Nothing iControlCount = DatabaseForm.getCount() If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object Set oCounter = New Collect oCounter._CollType = COLLCONTROLS oCounter._ParentType = OBJSUBFORM oCounter._ParentName = _Shortcut oCounter._Count = iControlCount Set Controls = oCounter Goto Exit_Function End If If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function ' Start building the ocControl object ' Determine exact name Set ocControl = New Control ocControl._ParentType = CTLPARENTISSUBFORM sParentShortcut = _Shortcut sControls() = DatabaseForm.getElementNames() 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) 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 End If Next i 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 Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("SubForm.Controls") Exit Function Trace_Error_Index: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) Set Controls = Nothing Goto Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name)) Set Controls = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "SubForm.Controls", Erl) Set Controls = Nothing GoTo Exit_Function End Function ' Controls V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name Utils._SetCalledSub("SubForm.getProperty") If IsMissing(pvProperty) Then Call _TraceArguments() getProperty = _PropertyGet(pvProperty) Utils._ResetCalledSub("SubForm.getProperty") End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean ' Return True if object has a valid property called pvProperty (case-insensitive comparison !) If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) Exit Function End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function Refresh() As Boolean ' Refresh data with its most recent value in the database in a form or subform Utils._SetCalledSub("SubForm.Refresh") If _ErrorHandler() Then On Local Error Goto Error_Function Refresh = False Dim oSet As Object Set oSet = DatabaseForm.createResultSet() If Not IsNull(oSet) Then oSet.refreshRow() Refresh = True End If Exit_Function: Set oSet = Nothing Utils._ResetCalledSub("SubForm.Refresh") Exit Function Error_Function: TraceError(TRACEABORT, Err, "SubForm.Refresh", Erl) GoTo Exit_Function End Function ' Refresh REM ----------------------------------------------------------------------------------------------------------------------- Public Function Requery() As Boolean ' Refresh data displayed in a form, subform, combobox or listbox Utils._SetCalledSub("SubForm.Requery") If _ErrorHandler() Then On Local Error Goto Error_Function Requery = False DatabaseForm.reload() Requery = True Exit_Function: Utils._ResetCalledSub("SubForm.Requery") Exit Function Error_Function: TraceError(TRACEABORT, Err, "SubForm.Requery", Erl) GoTo Exit_Function End Function ' Requery REM ----------------------------------------------------------------------------------------------------------------------- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean ' Return True if property setting OK Utils._SetCalledSub("SubForm.setProperty") setProperty = _PropertySet(psProperty, pvValue) Utils._ResetCalledSub("SubForm.setProperty") End Function REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant _PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "CurrentRecord" _ , "Filter", "FilterOn", "LinkChildFields", "LinkMasterFields", "Name" _ , "ObjectType", "OrderBy", "OrderByOn", "Parent", "RecordSource" _ ) ' Recordset removed End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String, ByVal Optional pvIndex As Variant) As Variant ' Return property value of the psProperty property name If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("SubForm.get" & psProperty) Dim iArgNr As Integer If Not IsMissing(pvIndex) Then Select Case UCase(_A2B_.CalledSub) Case UCase("getProperty") : iArgNr = 3 Case UCase("SubForm.getProperty") : iArgNr = 2 Case UCase("SubForm.get" & psProperty) : iArgNr = 1 End Select If Not Utils._CheckArgument(pvIndex, iArgNr, Utils._AddNumeric()) Then Goto Exit_Function End If 'Execute Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant _PropertyGet = vEMPTY Select Case UCase(psProperty) Case UCase("AllowAdditions") _PropertyGet = DatabaseForm.AllowInserts Case UCase("AllowDeletions") _PropertyGet = DatabaseForm.AllowDeletes Case UCase("AllowEdits") _PropertyGet = DatabaseForm.AllowUpdates Case UCase("CurrentRecord") _PropertyGet = DatabaseForm.Row Case UCase("Filter") _PropertyGet = DatabaseForm.Filter Case UCase("FilterOn") _PropertyGet = DatabaseForm.ApplyFilter Case UCase("LinkChildFields") If Utils._hasUNOProperty(DatabaseForm, "DetailFields") Then If IsMissing(pvIndex) Then _PropertyGet = DatabaseForm.DetailFields Else If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.DetailFields) Then Goto trace_Error_Index _PropertyGet = DatabaseForm.DetailFields(pvIndex) End If End If Case UCase("LinkMasterFields") If Utils._hasUNOProperty(DatabaseForm, "MasterFields") Then If IsMissing(pvIndex) Then _PropertyGet = DatabaseForm.MasterFields Else If pvIndex < 0 Or pvIndex > UBound(DatabaseForm.MasterFields) Then Goto trace_Error_Index _PropertyGet = DatabaseForm.MasterFields(pvIndex) End If End If Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") _PropertyGet = _Type Case UCase("OrderBy") _PropertyGet = _OrderBy Case UCase("OrderByOn") If DatabaseForm.Order = "" Then _PropertyGet = False Else _PropertyGet = True Case UCase("Recordset") If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? Set oObject = New Recordset With DatabaseForm oObject._CommandType = .CommandType oObject._Command = .Command oObject._ParentName = _Name oObject._ParentType = _Type Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) Set oObject._ParentDatabase = oDatabase Set oObject._ParentDatabase.Connection = .ActiveConnection oObject._ForwardOnly = ( .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY ) oObject._PassThrough = ( .EscapeProcessing = False ) oObject._ReadOnly = ( .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY ) Call oObject._Initialize() End With With oDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") .RecordsetsColl.Add(oObject, UCase(oObject._Name)) End With Set _PropertyGet = oObject Case UCase("RecordSource") _PropertyGet = DatabaseForm.ActiveCommand Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("SubForm.get" & psProperty) Exit Function Trace_Error: TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = vEMPTY Goto Exit_Function Trace_Error_Index: TraceError(TRACEFATAL, ERRINDEXVALUE, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = vEMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "SubForm._PropertyGet", Erl) _PropertyGet = vEMPTY GoTo Exit_Function End Function ' _PropertyGet REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean Utils._SetCalledSub("SubForm.set" & psProperty) If _ErrorHandler() Then On Local Error Goto Error_Function _PropertySet = True 'Execute Dim iArgNr As Integer If _IsLeft(_A2B_.CalledSub, "SubForm.") Then iArgNr = 1 Else iArgNr = 2 Select Case UCase(psProperty) Case UCase("AllowAdditions") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value DatabaseForm.AllowInserts = pvValue DatabaseForm.reload() Case UCase("AllowDeletions") If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value DatabaseForm.AllowDeletes = pvValue DatabaseForm.reload() Case UCase("AllowEdits") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value DatabaseForm.AllowUpdates = pvValue DatabaseForm.reload() Case UCase("CurrentRecord") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value DatabaseForm.absolute(pvValue) Case UCase("Filter") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) Case UCase("FilterOn") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value DatabaseForm.ApplyFilter = pvValue DatabaseForm.reload() Case UCase("OrderBy") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value _OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) Case UCase("OrderByOn") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If pvValue Then DatabaseForm.Order = _OrderBy Else DatabaseForm.Order = "" DatabaseForm.reload() Case UCase("RecordSource") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value DatabaseForm.Command = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) DatabaseForm.CommandType = com.sun.star.sdb.CommandType.COMMAND DatabaseForm.Filter = "" DatabaseForm.reload() Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("SubForm.set" & psProperty) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "SubForm._PropertySet", Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet