Quelle  Event.xba   Sprache: unbekannt

<?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>