File: //lib64/libreoffice/share/basic/Access2Base/Event.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="Event" 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 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)
Dim vEMPTY As Variant
_PropertyGet = vEMPTY
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 = vEMPTY
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Event._PropertyGet", Erl)
_PropertyGet = vEMPTY
GoTo Exit_Function
End Function ' _PropertyGet V1.1.0
</script:module>