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 EVENT Private _EventSource As Object Private _EventType As String Private _EventName As String Private _SubComponentName As String Private _SubComponentType As Long Private _ContextShortcut As String Private _ButtonLeft As Boolean ' com.sun.star.awt.MouseButton.XXX Private _ButtonRight As Boolean Private _ButtonMiddle As Boolean Private _XPos As Variant ' Null or Long Private _YPos As Variant ' Null or Long Private _ClickCount As Long Private _KeyCode As Integer ' com.sun.star.awt.Key.XXX Private _KeyChar As String Private _KeyFunction As Integer ' com.sun.star.awt.KeyFunction.XXX Private _KeyAlt As Boolean Private _KeyCtrl As Boolean Private _KeyShift As Boolean Private _FocusChangeTemporary As Boolean ' False if user action in same window Private _RowChangeAction As Long ' com.sun.star.sdb.RowChangeAction.XXX Private _Recommendation As String ' "IGNORE" or "" REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJEVENT _EventSource = Nothing _EventType = "" _EventName = "" _SubComponentName = "" _SubComponentType = -1 _ContextShortcut = "" _ButtonLeft = False ' See com.sun.star.awt.MouseButton.XXX _ButtonRight = False _ButtonMiddle = False _XPos = Null _YPos = Null _ClickCount = 0 _KeyCode = 0 _KeyChar = "" _KeyFunction = com.sun.star.awt.KeyFunction.DONTKNOW _KeyAlt = False _KeyCtrl = False _KeyShift = False _FocusChangeTemporary = False _RowChangeAction = 0 _Recommendation = "" 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 ButtonLeft() As Variant ButtonLeft = _PropertyGet("ButtonLeft") End Property ' ButtonLeft (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ButtonMiddle() As Variant ButtonMiddle = _PropertyGet("ButtonMiddle") End Property ' ButtonMiddle (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ButtonRight() As Variant ButtonRight = _PropertyGet("ButtonRight") End Property ' ButtonRight (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ClickCount() As Variant ClickCount = _PropertyGet("ClickCount") End Property ' ClickCount (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ContextShortcut() As Variant ContextShortcut = _PropertyGet("ContextShortcut") End Property ' ContextShortcut (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get EventName() As Variant EventName = _PropertyGet("EventName") End Property ' EventName (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get EventSource() As Variant EventSource = _PropertyGet("EventSource") End Property ' EventSource (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get EventType() As Variant EventType = _PropertyGet("EventType") End Property ' EventType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get FocusChangeTemporary() As Variant FocusChangeTemporary = _PropertyGet("FocusChangeTemporary") End Property ' FocusChangeTemporary (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get KeyAlt() As Variant KeyAlt = _PropertyGet("KeyAlt") End Property ' KeyAlt (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get KeyChar() As Variant KeyChar = _PropertyGet("KeyChar") End Property ' KeyChar (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get KeyCode() As Variant KeyCode = _PropertyGet("KeyCode") End Property ' KeyCode (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get KeyCtrl() As Variant KeyCtrl = _PropertyGet("KeyCtrl") End Property ' KeyCtrl (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get KeyFunction() As Variant KeyFunction = _PropertyGet("KeyFunction") End Property ' KeyFunction (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get KeyShift() As Variant KeyShift = _PropertyGet("KeyShift") End Property ' KeyShift (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String ObjectType = _PropertyGet("ObjectType") End Property ' ObjectType (get) 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, "", vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, "", vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Exit_Function: Set Properties = vProperty Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Property Get Recommendation() As Variant Recommendation = _PropertyGet("Recommendation") End Property ' Recommendation (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get RowChangeAction() As Variant RowChangeAction = _PropertyGet("RowChangeAction") End Property ' RowChangeAction (get) REM ----------------------------------------------------------------------------------------------------------------------- Public Function Source() As Variant ' Return the object having fired the event: Form, Control or SubForm ' Else return the root Database object Source = _PropertyGet("Source") End Function ' Source (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SubComponentName() As String SubComponentName = _PropertyGet("SubComponentName") End Property ' SubComponentName (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get SubComponentType() As Long SubComponentType = _PropertyGet("SubComponentType") End Property ' SubComponentType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get XPos() As Variant XPos = _PropertyGet("XPos") End Property ' XPos (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get YPos() As Variant YPos = _PropertyGet("YPos") End Property ' YPos (get) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- 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 ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _Initialize(poEvent As Object) Dim oObject As Object, i As Integer Dim sShortcut As String, sAddShortcut As String, sArray() As String Dim sImplementation As String, oSelection As Object Dim iCurrentDoc As Integer, oDoc As Object Const cstDatabaseForm = "com.sun.star.comp.forms.ODatabaseForm" If _ErrorHandler() Then On Local Error Goto Error_Function Set oObject = poEvent.Source _EventSource = oObject sArray = Split(Utils._getUNOTypeName(poEvent), ".") _EventType = UCase(sArray(UBound(sArray)) If Utils._hasUNOProperty(poEvent, "EventName") Then _EventName = poEvent.EventName Select Case _EventType Case "DOCUMENTEVENT" 'SubComponent processing Select Case UCase(_EventName) Case UCase("OnSubComponentClosed"), UCase("OnSubComponentOpened") Set oSelection = poEvent.ViewController.getSelection()(0) _SubComponentName = oSelection.Name With com.sun.star.sdb.application.DatabaseObject Select Case oSelection.Type Case .TABLE : _SubComponentType = acTable Case .QUERY : _SubComponentType = acQuery Case .FORM : _SubComponentType = acForm Case .REPORT : _SubComponentType = acReport Case Else End Select End With Case Else End Select Case "EVENTOBJECT" Case "ACTIONEVENT" Case "FOCUSEVENT" _FocusChangeTemporary = poEvent.Temporary Case "ITEMEVENT" Case "INPUTEVENT", "KEYEVENT" _KeyCode = poEvent.KeyCode _KeyChar = poEvent.KeyChar _KeyFunction = poEvent.KeyFunc _KeyAlt = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD2) _KeyCtrl = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.MOD1) _KeyShift = Utils._BitShift(poEvent.Modifiers, com.sun.star.awt.KeyModifier.SHIFT) Case "MOUSEEVENT" _ButtonLeft = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.LEFT) _ButtonRight = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.RIGHT) _ButtonMiddle = Utils._BitShift(poEvent.Buttons, com.sun.star.awt.MouseButton.MIDDLE) _XPos = poEvent.X _YPos = poEvent.Y _ClickCount = poEvent.ClickCount Case "ROWCHANGEEVENT" _RowChangeAction = poEvent.Action Case "TEXTEVENT" Case "ADJUSTMENTEVENT", "DOCKINGEVENT", "ENDDOCKINGEVENT", "ENDPOPUPMODEEVENT", "ENHANCEDMOUSEEVENT" _ , "MENUEVENT", "PAINTEVENT", "SPINEVENT", "VCLCONTAINEREVENT", "WINDOWEVENT" Goto Exit_Function Case Else Goto Exit_Function End Select ' Evaluate ContextShortcut sShortcut = "" sImplementation = Utils._ImplementationName(oObject) Select Case True Case sImplementation = "stardiv.Toolkit.UnoDialogControl" ' Dialog _ContextShortcut = "Dialogs!" & _EventSource.Model.Name Goto Exit_Function Case Left(sImplementation, 16) = "stardiv.Toolkit." ' Control in Dialog _ContextShortcut = "Dialogs!" & _EventSource.Context.Model.Name _ & "!" & _EventSource.Model.Name Goto Exit_Function Case Else End Select iCurrentDoc = _A2B_.CurrentDocIndex(, False) If iCurrentDoc < 0 Then Goto Exit_Function Set oDoc = _A2B_.CurrentDocument(iCurrentDoc) ' To manage 2x triggers of "Before record action" form event If _EventType = "ROWCHANGEEVENT" And sImplementation <> "com.sun.star.comp.forms.ODatabaseForm" Then _Recommendation = "IGNORE" Do While sImplementation <> "SwXTextDocument" sAddShortcut = "" Select Case sImplementation Case "com.sun.star.comp.forms.OFormsCollection" ' Do nothing Case Else If Utils._hasUNOProperty(oObject, "Model") Then If oObject.Model.Name <> "MainForm" And oObject.Model.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Model.Name) ElseIf Utils._hasUNOProperty(oObject, "Name") Then If oObject.Name <> "MainForm" And oObject.Name <> "Form" Then sAddShortcut = Utils._Surround(oObject.Name) End If If sAddShortcut <> "" Then If sImplementation = cstDatabaseForm And oDoc.DbConnect = DBCONNECTBASE Then sAddShortcut = sAddShortcut & ".Form" sShortcut = sAddShortcut & Iif(Len(sShortcut) > 0, "!" & sShortcut, "") End If End Select Select Case True Case Utils._hasUNOProperty(oObject, "Model") Set oObject = oObject.Model.Parent Case Utils._hasUNOProperty(oObject, "Parent") Set oObject = oObject.Parent Case Else Goto Exit_Function End Select sImplementation = Utils._ImplementationName(oObject) Loop ' Add Forms! prefix ' Select Case oDoc.DbConnect ' Case DBCONNECTBASE If Utils._hasUNOProperty(oObject, "Args") Then ' Current object is a SwXTextDocument For i = 0 To UBound(oObject.Args) If oObject.Args(i).Name = "DocumentTitle" Then sAddShortcut = Utils._Surround(oObject.Args(i).Value) Exit For End If Next i End If sShortcut = "Forms!" & sAddShortcut & "!" & sShortcut ' Case DBCONNECTFORM ' sShortcut = "Forms!0!" & sShortcut ' End Select sArray = Split(sShortcut, "!") ' If presence of "Forms!myform!myform.Form", eliminate 2nd element ' Eliminate anyway blanco subcomponents (e.g; Forms!!myForm) If UBound(sArray) >= 2 Then If UCase(sArray(1)) & ".FORM" = UCase(sArray(2)) Then sArray(1) = "" sArray = Utils._TrimArray(sArray) End If ' If first element ends with .Form, remove suffix If UBound(sArray) >= 1 Then If Len(sArray(1)) > 5 And Right(sArray(1), 5) = ".Form" Then sArray(1) = left(sArray(1), Len(sArray(1)) - 5) sShortcut = Join(sArray, "!") End If If Len(sShortcut) >= 2 Then If Right(sShortcut, 1) = "!" Then _ContextShortcut = Left(sShortcut, Len(sShortcut) - 1) Else _ContextShortcut = sShortcut End If End If Exit_Function: Exit Sub Error_Function: TraceError(TRACEWARNING, Err, "Event.Initialize", Erl) GoTo Exit_Function End Sub ' _Initialize V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant Dim sSubComponentName As String, sSubComponentType As String sSubComponentName = Iif(_SubComponentType > -1, "SubComponentName", "") sSubComponentType = Iif(_SubComponentType > -1, "SubComponentType", "") Dim sXPos As String, sYPos As String sXPos = Iif(IsNull(_XPos), "", "XPos") sYPos = Iif(IsNull(_YPos), "", "YPos") _PropertiesList = Utils._TrimArray(Array( _ "ButtonLeft", "ButtonRight", "ButtonMiddle", "ClickCount" _ , "ContextShortcut", "EventName", "EventType", "FocusChangeTemporary", _ , "KeyAlt", "KeyChar", "KeyCode", "KeyCtrl", "KeyFunction", "KeyShift" _ , "ObjectType", "Recommendation", "RowChangeAction", "Source" _ , sSubComponentName, sSubComponentType, sXPos, sYPos _ )) 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("Event.get" & psProperty) _PropertyGet = EMPTY Select Case UCase(psProperty) Case UCase("ButtonLeft") _PropertyGet = _ButtonLeft Case UCase("ButtonMiddle") _PropertyGet = _ButtonMiddle Case UCase("ButtonRight") _PropertyGet = _ButtonRight Case UCase("ClickCount") _PropertyGet = _ClickCount Case UCase("ContextShortcut") _PropertyGet = _ContextShortcut Case UCase("FocusChangeTemporary") _PropertyGet = _FocusChangeTemporary Case UCase("EventName") _PropertyGet = _EventName Case UCase("EventSource") _PropertyGet = _EventSource Case UCase("EventType") _PropertyGet = _EventType Case UCase("KeyAlt") _PropertyGet = _KeyAlt Case UCase("KeyChar") _PropertyGet = _KeyChar Case UCase("KeyCode") _PropertyGet = _KeyCode Case UCase("KeyCtrl") _PropertyGet = _KeyCtrl Case UCase("KeyFunction") _PropertyGet = _KeyFunction Case UCase("KeyShift") _PropertyGet = _KeyShift Case UCase("ObjectType") _PropertyGet = _Type Case UCase("Recommendation") _PropertyGet = _Recommendation Case UCase("RowChangeAction") _PropertyGet = _RowChangeAction Case UCase("Source") If _ContextShortcut = "" Then _PropertyGet = _EventSource Else _PropertyGet = getObject(_ContextShortcut) End If Case UCase("SubComponentName") _PropertyGet = _SubComponentName Case UCase("SubComponentType") _PropertyGet = _SubComponentType Case UCase("XPos") If IsNull(_XPos) Then Goto Trace_Error _PropertyGet = _XPos Case UCase("YPos") If IsNull(_YPos) Then Goto Trace_Error _PropertyGet = _YPos Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub("Event.get" & psProperty) Exit Function Trace_Error: ' Errors are not displayed to avoid display infinite cycling TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, False, psProperty) _PropertyGet = EMPTY Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl) _PropertyGet = EMPTY GoTo Exit_Function End Function ' _PropertyGet V1.1.0