EVOLUTION-MANAGER
Edit File: Form.xba
<?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Form" script:language="StarBasic">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 FORM Private _Shortcut As String Private _Name As String Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure Private _DbEntry As Integer 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 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 = OBJFORM _Shortcut = "" _Name = "" _DocEntry = -1 _DbEntry = -1 _IsLoaded = False _OpenArgs = "" _OrderBy = "" Set Component = Nothing Set ContainerWindow = 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() Dim ofForm As Object If Not IsLoaded(True) Then If Not IsNull(DatabaseForm) Then DatabaseForm.Dispose() End If 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 Bookmark() As Variant Bookmark = _PropertyGet("Bookmark") End Property ' Bookmark (get) Property Let Bookmark(ByVal pvValue As Variant) Call _PropertySet("Bookmark", pvValue) End Property ' Bookmark (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Caption() As Variant Caption = _PropertyGet("Caption") End Property ' Caption (get) Property Let Caption(ByVal pvValue As Variant) Call _PropertySet("Caption", pvValue) End Property ' Caption (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 Height() As Variant Height = _PropertyGet("Height") End Property ' Height (get) Property Let Height(ByVal pvValue As Variant) Call _PropertySet("Height", pvValue) End Property ' Height (set) REM ----------------------------------------------------------------------------------------------------------------------- Function IsLoaded(ByVal Optional pbForce As Boolean) As Boolean 'Return True if form open 'pbForce = True forbids bypass on value of _IsLoaded If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Form.getIsLoaded") If IsMissing(pbForce) Then pbForce = False If ( Not pbForce ) And _IsLoaded Then ' For performance reasons, a form object, once detected as loaded, is presumed remaining loaded. Except if pbForce = True IsLoaded = True Goto Exit_Function End If IsLoaded = False Dim oDoc As Object, oDatabase As Object, oEnum As Object, oDesk As Object, oComp As Object, bFound As Boolean Dim i As Integer Set oDoc = _A2B_.CurrentDocument() Select Case oDoc.DbConnect Case DBCONNECTBASE Set oDesk = CreateUnoService("com.sun.star.frame.Desktop") Set oEnum = oDesk.Components().createEnumeration bFound = False Do While oEnum.hasMoreElements And Not bFound ' Search in all open components if one corresponds with current form oComp = oEnum.nextElement If HasUnoInterfaces(oComp, "com.sun.star.frame.XModule") Then If oComp.Identifier = "com.sun.star.sdb.FormDesign" Then For i = 0 To UBound(oComp.Args()) If oComp.Args(i).Name = "DocumentTitle" Then bFound = ( oComp.Args(i).Value = _Name ) If bFound Then _IsLoaded = True Set Component = oComp Exit For End If End If Next i End If End If Loop Case DBCONNECTFORM Set Component = oDoc.Document ' Form _IsLoaded = True ' Interactive form always loaded by design End Select Set oComp = Nothing IsLoaded = _IsLoaded Exit_Function: Utils._ResetCalledSub("Form.getIsLoaded") Exit Function Error_Function: TraceError(TRACEABORT, Err, "Form.getIsLoaded", Erl) GoTo Exit_Function End Function ' IsLoaded V1.1.0 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 ----------------------------------------------------------------------------------------------------------------------- Property Get OpenArgs() As Variant OpenArgs = _PropertyGet("OpenArgs") End Property ' OpenArgs (get) 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 OptionGroup(ByVal Optional pvGroupName As Variant) As Variant ' Return either an error or an object of type OPTIONGROUP based on its name Const cstThisSub = "Form.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, CTLPARENTISFORM, Component, 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, Form.OptionGroup, Erl) GoTo Exit_Function End Function ' OptionGroup V1.1.0 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 ----------------------------------------------------------------------------------------------------------------------- Property Get Visible() As Variant Visible = _PropertyGet("Visible") End Property ' Visible (get) Property Let Visible(ByVal pvValue As Variant) Call _PropertySet("Visible", pvValue) End Property ' Visible (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Width() As Variant Width = _PropertyGet("Width") End Property ' Width (get) Property Let Width(ByVal pvValue As Variant) Call _PropertySet("Width", pvValue) End Property ' Width (set) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Function mClose() As Variant ' Close the form If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Form.Close") mClose = False Dim oDatabase As Object, oController As Object Set oDatabase = Application._CurrentDb() If oDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Set oController = oDatabase.Document.getFormDocuments.getByName(_Name) oController.close() Dispose() mClose = True Exit_Function: Utils._ResetCalledSub("Form.Close") Exit Function Error_NotApplicable: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Form.Close", Erl) GoTo Exit_Function End Function 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("Form.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 If Not IsLoaded Then Goto Trace_Error_NotOpen Set ocControl = New Control ocControl._ParentType = CTLPARENTISFORM sParentShortcut = _Shortcut iControlCount = DatabaseForm.getCount() If IsMissing(pvIndex) Then ' No argument, return Collection pseudo-object Set oCounter = New Collect oCounter._CollType = COLLCONTROLS oCounter._ParentType = OBJFORM oCounter._ParentName = _Name 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 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 = 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 ocControl._Initialize() ocControl._DocEntry = _DocEntry ocControl._DbEntry = _DbEntry Set Controls = ocControl Exit_Function: Utils._ResetCalledSub("Form.Controls") Exit Function Trace_Error_NotOpen: TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, , _Name) Set Controls = Nothing Goto 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, pvIndex)) Set Controls = Nothing Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Form.Controls", Erl) Set Controls = Nothing GoTo Exit_Function End Function ' Controls REM ----------------------------------------------------------------------------------------------------------------------- Public Function CurrentDb() As Object ' Returns Database object related to current form Const cstThisSub = "Form.CurrentDb" Utils._SetCalledSub(cstThisSub) Set CurrentDb = Application._CurrentDb(_DocEntry, _DbEntry) Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' CurrentDb V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name Utils._SetCalledSub("Form.getProperty") If IsMissing(pvProperty) Then Call _TraceArguments() getProperty = _PropertyGet(pvProperty) Utils._ResetCalledSub("Form.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 Move( ByVal Optional pvLeft As Variant _ , ByVal Optional pvTop As Variant _ , ByVal Optional pvWidth As Variant _ , ByVal Optional pvHeight As Variant _ ) As Variant ' Execute Move method Utils._SetCalledSub("Form.Move") If IsMissing(pvLeft) Then Call _TraceArguments() If _ErrorHandler() Then On Local Error Goto Error_Function Move = False Dim iArgNr As Integer Select Case UCase(_A2B_.CalledSub) Case UCase("Move") : iArgNr = 1 Case UCase("Form.Move") : iArgNr = 0 End Select If IsMissing(pvLeft) Then Call _TraceArguments() If IsMissing(pvTop) Then pvTop = -1 If IsMissing(pvWidth) Then pvWidth = -1 If IsMissing(pvHeight) Then pvHeight = -1 If Not Utils._CheckArgument(pvLeft, iArgNr + 1, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvTop, iArgNr + 2, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvWidth, iArgNr + 3, Utils._AddNumeric()) Then Goto Exit_Function If Not Utils._CheckArgument(pvHeight, iArgNr + 4, Utils._AddNumeric()) Then Goto Exit_Function Dim iArg As Integer, iWrong As Integer ' Check arguments values iArg = 0 If pvHeight < -1 Then iArg = 4 : iWrong = pvHeight ElseIf pvWidth < -1 Then iArg = 3 : iWrong = pvWidth ElseIf pvTop < -1 Then iArg = 2 : iWrong = pvTop ElseIf pvLeft < -1 Then iArg = 1 : iWrong = pvLeft End If If iArg > 0 Then TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(iArgNr + iArg, iWrong)) Goto Exit_Function End If Dim iPosSize As Integer iPosSize = 0 If pvLeft >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.X If pvTop >= 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.Y If pvWidth > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.WIDTH If pvHeight > 0 Then iPosSize = iPosSize + com.sun.star.awt.PosSize.HEIGHT If iPosSize > 0 Then If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 ContainerWindow.IsMaximized = False ContainerWindow.IsMinimized = False End If ContainerWindow.setPosSize(pvLeft, pvTop, pvWidth, pvHeight, iPosSize) End If Move = True Exit_Function: Utils._ResetCalledSub("Form.Move") Exit Function Error_Function: TraceError(TRACEABORT, Err, "Form.Move", Erl) GoTo Exit_Function End Function ' Move REM ----------------------------------------------------------------------------------------------------------------------- Public Function Refresh() As Boolean ' Refresh data with its most recent value in the database in a form or subform Utils._SetCalledSub("Form.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("Form.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("Form.Requery") If _ErrorHandler() Then On Local Error Goto Error_Function Requery = False DatabaseForm.reload() Requery = True Exit_Function: Utils._ResetCalledSub("Form.Requery") Exit Function Error_Function: TraceError(TRACEABORT, Err, "Form.Requery", Erl) GoTo Exit_Function End Function ' Requery REM ----------------------------------------------------------------------------------------------------------------------- Public Function setFocus() As Boolean ' Execute setFocus method Const cstThisSub = "Form.setFocus" Utils._SetCalledSub(cstThisSub) If _ErrorHandler() Then On Local Error Goto Error_Function setFocus = False With ContainerWindow If .isVisible() = False Then .setVisible(True) .IsMinimized = False .setFocus() .setEnable(True) ' Added to try to bypass desynchro issue in Linux .toFront() ' Added to force window change in Linux End With setFocus = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) Goto Exit_Function End Function ' setFocus V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean ' Return True if property setting OK Utils._SetCalledSub("Form.setProperty") setProperty = _PropertySet(psProperty, pvValue) Utils._ResetCalledSub("Form.setProperty") End Function REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _Initialize(psName As String) ' Set pointers to UNO objects Dim oDoc As Object, oFormsCollection As Object, oDatabase As Object If _ErrorHandler() Then On Local Error Goto Trace_Error _Name = psName _Shortcut = "Forms!" & Utils._Surround(psName) If IsLoaded Then Set oDoc = _A2B_.CurrentDocument() Select Case oDoc.DbConnect 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.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 End If End If Case DBCONNECTFORM Set ContainerWindow = oDoc.Document.CurrentController.Frame.ContainerWindow Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) With oDatabase Set DatabaseForm = .Form If IsNull(.Connection) Then Set .Connection = DatabaseForm.ActiveConnection If Not IsNull(.Connection) Then Set .MetaData = .Connection.MetaData oDatabase._ReadOnly = .Connection.isReadOnly() End If End If End With End Select _OrderBy = DatabaseForm.Order Else Set Component = Nothing Set ContainerWindow = Nothing Set DatabaseForm = Nothing End If Exit_Sub: Exit Sub Trace_Error: TraceError(TRACEABORT, Err, "Form.Initialize", Erl) Goto Exit_Sub Trace_Internal_Error: TraceError(TRACEABORT, ERRFORMNOTIDENTIFIED, Utils._CalledSub(), 0, , _Name) Goto Exit_Sub End Sub ' _Initialize V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant If IsLoaded Then _PropertiesList = Array("AllowAdditions", "AllowDeletions", "AllowEdits", "Bookmark" _ , "Caption", "CurrentRecord", "Filter", "FilterOn", "Height", "IsLoaded" _ , "Name", "ObjectType", "OpenArgs", "OrderBy", "OrderByOn" _ , "RecordSource", "Visible", "Width" _ ) ' Recordset removed Else _PropertiesList = Array("IsLoaded", "Name" _ ) End If End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String) As Variant ' Return property value of the psProperty property name If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub("Form.get" & psProperty) 'Execute Dim oDatabase As Object, vBookmark As Variant, vEMPTY As Variant Dim oObject As Object _PropertyGet = vEMPTY Select Case UCase(psProperty) Case UCase("Name"), UCase("IsLoaded") Case Else : If Not IsLoaded Then Goto Trace_Error_Form End Select Select Case UCase(psProperty) Case UCase("AllowAdditions") _PropertyGet = DatabaseForm.AllowInserts Case UCase("AllowDeletions") _PropertyGet = DatabaseForm.AllowDeletes Case UCase("AllowEdits") _PropertyGet = DatabaseForm.AllowUpdates Case UCase("Bookmark") On Local Error Resume Next ' Disable error handler because bookmarking does not always react well in events ... If DatabaseForm.IsBookmarkable Then vBookmark = DatabaseForm.getBookmark() Else vBookmark = Nothing If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0 If IsNull(vBookmark) Then Goto Trace_Error _PropertyGet = vBookmark Case UCase("Caption") Set odatabase = Application._CurrentDb(_DocEntry, _DbEntry) Select Case oDatabase._DbConnect Case DBCONNECTFORM : _PropertyGet = oDatabase.Document.CurrentController.Frame.Title Case DBCONNECTBASE : _PropertyGet = Component.CurrentController.Frame.Title End Select Case UCase("CurrentRecord") _PropertyGet = DatabaseForm.Row Case UCase("Filter") _PropertyGet = DatabaseForm.Filter Case UCase("FilterOn") _PropertyGet = DatabaseForm.ApplyFilter Case UCase("Height") _PropertyGet = ContainerWindow.getPosSize().Height Case UCase("IsLoaded") ' Only for indirect access from property object _PropertyGet = IsLoaded Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") _PropertyGet = _Type Case UCase("OpenArgs") _PropertyGet = _OpenArgs 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 If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty Set _PropertyGet = oObject Case UCase("RecordSource") _PropertyGet = DatabaseForm.ActiveCommand Case UCase("Visible") _PropertyGet = ContainerWindow.IsVisible() Case UCase("Width") _PropertyGet = ContainerWindow.getPosSize().Width Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("Form.get" & psProperty) Exit Function Trace_Error: TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertyGet = vEMPTY Goto Exit_Function Trace_Error_Form: TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) _PropertyGet = vEMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Form._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("Form.set" & psProperty) If _ErrorHandler() Then On Local Error Goto Error_Function _PropertySet = True 'Execute Dim iArgNr As Integer Dim oDatabase As Object If _Isleft(_A2B_.CalledSub, "Form.") Then iArgNr = 1 Else iArgNr = 2 If Not IsLoaded Then Goto Trace_Error_Form 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("Bookmark") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(vbObject), , False) Then Goto Trace_Error_Value If IsNull(pvValue) Then Goto Trace_Error_Value DatabaseForm.MoveToBookmark(pvValue) Case UCase("Caption") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value Set oDatabase = Application._CurrentDb(_DocEntry, _DbEntry) Select Case oDatabase._DbConnect Case DBCONNECTFORM : oDatabase.Document.CurrentController.Frame.Title = pvValue Case DBCONNECTBASE : Component.CurrentController.Frame.Title = pvValue End Select Case UCase("CurrentRecord") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 1 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("Height") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 ContainerWindow.IsMaximized = False ContainerWindow.IsMinimized = False End If ContainerWindow.setPosSize(0, 0, 0, pvValue, com.sun.star.awt.PosSize.HEIGHT) 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 UCase("Visible") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value ContainerWindow.setVisible(pvValue) Case UCase("Width") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric()) Then Goto Trace_Error_Value If Utils._hasUNOProperty(ContainerWindow, "IsMaximized") Then ' Ignored when <= OO3.2 ContainerWindow.IsMaximized = False ContainerWindow.IsMinimized = False End If ContainerWindow.setPosSize(0, 0, pvValue, 0, com.sun.star.awt.PosSize.WIDTH) Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("Form.set" & psProperty) Exit Function Trace_Error_Form: TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) _PropertySet = False Goto 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, "Form._PropertySet", Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet </script:module>