Server : Apache/2.4.6 (CentOS) OpenSSL/1.0.2k-fips PHP/7.4.20 System : Linux st2.domain.com 3.10.0-1127.10.1.el7.x86_64 #1 SMP Wed Jun 3 14:28:03 UTC 2020 x86_64 User : apache ( 48) PHP Version : 7.4.20 Disable Function : NONE Directory : /opt/libreoffice6.4/share/basic/Access2Base/ |
<?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 _This As Object ' Workaround for absence of This builtin function Private _Parent As Object 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 _PersistentName As String 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 ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJFORM Set _This = Nothing Set _Parent = Nothing _Shortcut = "" _Name = "" _DocEntry = -1 _DbEntry = -1 _MainForms = Array() _PersistentName = "" _IsLoaded = False _OpenArgs = "" _OrderBy = "" Set Component = Nothing Set ContainerWindow = Nothing Set FormsCollection = 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, vPersistent As Variant 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 Do While oEnum.hasMoreElements ' Search in all open components if one corresponds with current form oComp = oEnum.nextElement If _hasUNOProperty(oComp, "Identifier") Then If oComp.Identifier = "com.sun.star.sdb.FormDesign" Then vPersistent = Split(oComp.StringValue, "/") If vPersistent(UBound(vPersistent) - 1) = _PersistentName Then _IsLoaded = True Set Component = oComp Exit Do End If 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 OnApproveCursorMove() As Variant OnApproveCursorMove = _PropertyGet("OnApproveCursorMove") End Property ' OnApproveCursorMove (get) Property Let OnApproveCursorMove(ByVal pvValue As Variant) Call _PropertySet("OnApproveCursorMove", pvValue) End Property ' OnApproveCursorMove (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveParameter() As Variant OnApproveParameter = _PropertyGet("OnApproveParameter") End Property ' OnApproveParameter (get) Property Let OnApproveParameter(ByVal pvValue As Variant) Call _PropertySet("OnApproveParameter", pvValue) End Property ' OnApproveParameter (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveReset() As Variant OnApproveReset = _PropertyGet("OnApproveReset") End Property ' OnApproveReset (get) Property Let OnApproveReset(ByVal pvValue As Variant) Call _PropertySet("OnApproveReset", pvValue) End Property ' OnApproveReset (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveRowChange() As Variant OnApproveRowChange = _PropertyGet("OnApproveRowChange") End Property ' OnApproveRowChange (get) Property Let OnApproveRowChange(ByVal pvValue As Variant) Call _PropertySet("OnApproveRowChange", pvValue) End Property ' OnApproveRowChange (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnApproveSubmit() As Variant OnApproveSubmit = _PropertyGet("OnApproveSubmit") End Property ' OnApproveSubmit (get) Property Let OnApproveSubmit(ByVal pvValue As Variant) Call _PropertySet("OnApproveSubmit", pvValue) End Property ' OnApproveSubmit (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnConfirmDelete() As Variant OnConfirmDelete = _PropertyGet("OnConfirmDelete") End Property ' OnConfirmDelete (get) Property Let OnConfirmDelete(ByVal pvValue As Variant) Call _PropertySet("OnConfirmDelete", pvValue) End Property ' OnConfirmDelete (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnCursorMoved() As Variant OnCursorMoved = _PropertyGet("OnCursorMoved") End Property ' OnCursorMoved (get) Property Let OnCursorMoved(ByVal pvValue As Variant) Call _PropertySet("OnCursorMoved", pvValue) End Property ' OnCursorMoved (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnErrorOccurred() As Variant OnErrorOccurred = _PropertyGet("OnErrorOccurred") End Property ' OnErrorOccurred (get) Property Let OnErrorOccurred(ByVal pvValue As Variant) Call _PropertySet("OnErrorOccurred", pvValue) End Property ' OnErrorOccurred (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnLoaded() As Variant OnLoaded = _PropertyGet("OnLoaded") End Property ' OnLoaded (get) Property Let OnLoaded(ByVal pvValue As Variant) Call _PropertySet("OnLoaded", pvValue) End Property ' OnLoaded (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnReloaded() As Variant OnReloaded = _PropertyGet("OnReloaded") End Property ' OnReloaded (get) Property Let OnReloaded(ByVal pvValue As Variant) Call _PropertySet("OnReloaded", pvValue) End Property ' OnReloaded (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnReloading() As Variant OnReloading = _PropertyGet("OnReloading") End Property ' OnReloading (get) Property Let OnReloading(ByVal pvValue As Variant) Call _PropertySet("OnReloading", pvValue) End Property ' OnReloading (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnResetted() As Variant OnResetted = _PropertyGet("OnResetted") End Property ' OnResetted (get) Property Let OnResetted(ByVal pvValue As Variant) Call _PropertySet("OnResetted", pvValue) End Property ' OnResetted (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnRowChanged() As Variant OnRowChanged = _PropertyGet("OnRowChanged") End Property ' OnRowChanged (get) Property Let OnRowChanged(ByVal pvValue As Variant) Call _PropertySet("OnRowChanged", pvValue) End Property ' OnRowChanged (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnUnloaded() As Variant OnUnloaded = _PropertyGet("OnUnloaded") End Property ' OnUnloaded (get) Property Let OnUnloaded(ByVal pvValue As Variant) Call _PropertySet("OnUnloaded", pvValue) End Property ' OnUnloaded (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get OnUnloading() As Variant OnUnloading = _PropertyGet("OnUnloading") End Property ' OnUnloading (get) Property Let OnUnloading(ByVal pvValue As Variant) Call _PropertySet("OnUnloading", pvValue) End Property ' OnUnloading (set) 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, FormsCollection) 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 Parent() As Object Parent = _Parent End Function ' Parent (get) V6.4.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, _This, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _This, 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.getByHierarchicalName(_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 ' Close 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, iControlCount As Integer Dim oCounter As Variant, sControls() As Variant, i As Integer, bFound As Boolean, sIndex As String 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 '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 Set oCounter._This = oCounter oCounter._CollType = COLLCONTROLS Set oCounter._Parent = _This 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 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 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) sIndex = UCase(Utils._Trim(pvIndex)) 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 Not bFound Then Goto Trace_NotFound End Select 'Initialize a new Control object Set ocControl = New Control With ocControl Set ._This = ocControl Set ._Parent = _This ._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 ._Initialize() ._DocEntry = _DocEntry ._DbEntry = _DbEntry End With 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 _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 pvLeft = -1 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 ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _GetListener(ByVal psProperty As String) As String ' Return the X...Listener corresponding with the property in argument Select Case UCase(psProperty) Case UCase("OnApproveCursorMove") _GetListener = "XRowSetApproveListener" Case UCase("OnApproveParameter") _GetListener = "XDatabaseParameterListener" Case UCase("OnApproveReset"), UCase("OnResetted") _GetListener = "XResetListener" Case UCase("OnApproveRowChange") _GetListener = "XRowSetApproveListener" Case UCase("OnApproveSubmit") _GetListener = "XSubmitListener" Case UCase("OnConfirmDelete") _GetListener = "XConfirmDeleteListener" Case UCase("OnCursorMoved"), UCase("OnRowChanged") _GetListener = "XRowSetListener" Case UCase("OnErrorOccurred") _GetListener = "XSQLErrorListener" Case UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnUnloaded"), UCase("OnUnloading") _GetListener = "XLoadListener" End Select End Function ' _GetListener V1.7.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _Initialize(psName As String) ' Set pointers to UNO objects Dim oDoc As Object, oDatabase As Object If _ErrorHandler() Then On Local Error Goto Trace_Error _Name = psName _Shortcut = "Forms!" & Utils._Surround(psName) Set oDoc = _A2B_.CurrentDocument() If oDoc.DbConnect = DBCONNECTBASE Then _PersistentName = oDoc.Document.getFormDocuments().getByHierarchicalName(psName).PersistentName If IsLoaded Then 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 FormsCollection = Component.getDrawPage.Forms If FormsCollection.Count = 0 Then Set DatabaseForm = Nothing Else '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 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 If IsNull(DatabaseForm) Then _OrderBy = "" Else _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", "OnApproveCursorMove", "OnApproveParameter" _ , "OnApproveReset", "OnApproveRowChange", "OnApproveSubmit", "OnConfirmDelete" _ , "OnCursorMoved", "OnErrorOccurred", "OnLoaded", "OnReloaded", "OnReloading" _ , "OnResetted", "OnRowChanged", "OnUnloaded", "OnUnloading", "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 Dim i As Integer, oObject As Object _PropertyGet = EMPTY 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") If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowInserts Case UCase("AllowDeletions") If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowDeletes Case UCase("AllowEdits") If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = DatabaseForm.AllowUpdates Case UCase("Bookmark") If IsNull(DatabaseForm) Then _PropertyGet = 0 Else 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 End If 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") If IsNull(DatabaseForm) Then _PropertyGet = 0 Else _PropertyGet = DatabaseForm.Row Case UCase("Filter") If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Filter Case UCase("FilterOn") If IsNull(DatabaseForm) Then _PropertyGet = False Else _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("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ , UCase("OnUnloaded"), UCase("OnUnloading") If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = Utils._GetEventScriptCode(DatabaseForm, psProperty, _Name, True) Case UCase("OpenArgs") _PropertyGet = _OpenArgs Case UCase("OrderBy") _PropertyGet = _OrderBy Case UCase("OrderByOn") If IsNull(DatabaseForm) Then _PropertyGet = False Else _PropertyGet = ( DatabaseForm.Order <> "" ) Case UCase("Recordset") If IsNull(DatabaseForm) Then Goto Trace_Error If DatabaseForm.Command = "" Then Goto Trace_Error ' No underlying data ?? Set oObject = New Recordset With DatabaseForm oObject._This = oObject 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") If IsNull(DatabaseForm) Then _PropertyGet = "" Else _PropertyGet = DatabaseForm.Command 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 = EMPTY Goto Exit_Function Trace_Error_Form: TraceError(TRACEFATAL, ERRFORMNOTOPEN, Utils._CalledSub(), 0, 1, _Name) _PropertyGet = EMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Form._PropertyGet", Erl) _PropertyGet = EMPTY 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, i 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 If IsNull(DatabaseForm) Then Goto Trace_Error DatabaseForm.AllowInserts = pvValue DatabaseForm.reload() Case UCase("AllowDeletions") If Not Utils._CheckArgument(pvValue,iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error DatabaseForm.AllowDeletes = pvValue DatabaseForm.reload() Case UCase("AllowEdits") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error 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 If IsNull(DatabaseForm) Then Goto Trace_Error 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 If IsNull(DatabaseForm) Then Goto Trace_Error DatabaseForm.absolute(pvValue) Case UCase("Filter") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error DatabaseForm.Filter = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) Case UCase("FilterOn") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error 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("OnApproveCursorMove"), UCase("OnApproveParameter"), UCase("OnApproveReset"), UCase("OnApproveRowChange") _ , UCase("OnApproveSubmit"), UCase("OnConfirmDelete"), UCase("OnCursorMoved"), UCase("OnErrorOccurred") _ , UCase("OnLoaded"), UCase("OnReloaded"), UCase("OnReloading"), UCase("OnResetted"), UCase("OnRowChanged") _ , UCase("OnUnloaded"), UCase("OnUnloading") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error If Not Utils._RegisterEventScript(DatabaseForm _ , psProperty _ , _GetListener(psProperty) _ , pvValue, _Name, True _ ) Then GoTo Trace_Error Case UCase("OrderBy") If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error _OrderBy = Application._CurrentDb(_DocEntry, _DbEntry)._ReplaceSquareBrackets(pvValue) Case UCase("OrderByOn") If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value If IsNull(DatabaseForm) Then Goto Trace_Error 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 If IsNull(DatabaseForm) Then Goto Trace_Error 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>