D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
lib
/
libreoffice
/
share
/
basic
/
Access2Base
/
Filename :
Event.xba
back
Copy
<?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, _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 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 Dim vPersistent As Variant 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 vPersistent = Split(oObject.StringValue, "/") sAddShortcut = Utils._Surround(_GetHierarchicalName(vPersistent(UBound(vPersistent) - 1))) 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 </script:module>