Access2Base - Implement On ... event properties

Event properties applied to form, subform, control events
Controls may belong to forms, subforms, dialogs, grid controls

Change-Id: Iaf33adcd03527ac938913675cf0930e317a17f97

wizards/source/access2base/Collect.xba

@@ -105,8 +105,10 @@ Dim vNames() As Variant, oProperty As Object
 			End Select
 		Case COLLPROPERTIES
 			Select Case _ParentType
-				Case OBJCONTROL, OBJSUBFORM
+				Case OBJCONTROL
 					Set Item = getObject(_ParentName).Properties(pvItem)
+				Case OBJSUBFORM
+					Set Item = getValue(_ParentName).Properties(pvItem)
 				Case OBJDATABASE
 					Set Item = _ParentDatabase.Properties(pvItem)
 				Case OBJDIALOG

wizards/source/access2base/Compatible.xba

@@ -19,7 +19,7 @@ Dim vVarTypes() As Variant, i As Integer
 Const cstTab = 5
 	On Local Error Goto Exit_Sub	'	Never interrupt processing
 	Utils._SetCalledSub("DebugPrint")
-	vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, 8192 + vbByte))
+	vVarTypes = Utils._AddNumeric(Array(vbEmpty, vbNull, vbDate, vbString, vbBoolean, vbObject, vbVariant, vbByte, vbArray + vbByte))
 	
 	If UBound(pvArgs) >= 0 Then
 		For i = 0 To UBound(pvArgs)
@@ -34,7 +34,7 @@ Const cstTab = 5
 Dim sOutput As String, sArg As String
 	sOutput = ""	
 	For i = 0 To UBound(pvArgs)
-		sArg = Utils._CStr(pvArgs(i))
+		sArg = Utils._CStr(pvArgs(i), _A2B_.DebugPrintShort)
 		' Add argument to output
 		If i = 0 Then
 			sOutput = sArg

wizards/source/access2base/Root_.xba

@@ -25,6 +25,7 @@ Private TraceLogCount		As Integer
 Private TraceLogLast		As Integer
 Private TraceLogMaxEntries	As Integer
 Private CalledSub			As String
+Private DebugPrintShort		As Boolean
 Private Introspection		As Object				'	com.sun.star.beans.Introspection	
 Private VersionNumber		As String				'	Actual Access2Base version number
 Private Locale				As String
@@ -47,6 +48,7 @@ Dim vCurrentDoc() As Variant
 	TraceLogLast = 0
 	TraceLogMaxEntries = 0
 	CalledSub = ""
+	DebugPrintShort = True
 	Locale = L10N._GetLocale()
 	Set Introspection = CreateUnoService("com.sun.star.beans.Introspection")
 	Set FindRecord = Nothing

wizards/source/access2base/Utils.xba

@@ -215,6 +215,45 @@ Dim oDialogLib As Object
 
 End Function
 
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _GetEventScriptCode(poObject As Object _
+					, ByVal psEvent As String _
+					, ByVal psName As String _
+					, Optional ByVal pbExtendName As Boolean _
+					) As String
+'	Extract from the parent of poObject the macro linked to psEvent.
+'	psName is the name of the object
+
+Dim i As Integer, vEvents As Variant, sEvent As String, oParent As Object, iIndex As Integer, sName As String
+
+	_GetEventScriptCode = ""
+	If Not Utils._hasUNOMethod(poObject, "getParent") Then Exit Function
+
+	'	Find form index i.e. find control via getByIndex() 
+	If IsMissing(pbExtendName) Then pbExtendName = False
+	Set oParent = poObject.getParent()
+	iIndex = -1
+	For i = 0 To oParent.getCount() - 1
+		sName = oParent.getByIndex(i).Name
+		If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
+			iIndex = i
+			Exit For
+		End If
+	Next i
+	If iIndex < 0 Then Exit Function
+	
+	'	Find script event
+	vEvents = oParent.getScriptEvents(iIndex)			'	Returns an array
+	sEvent = Utils._GetEventName(psEvent)			'	Targeted event method
+	For i = 0 To UBound(vEvents)
+		If vEvents(i).EventMethod = sEvent Then
+			_GetEventScriptCode = vEvents(i).ScriptCode
+			Exit For
+		End If
+	Next i
+
+End Function	'	_GetEventScriptCode	V1.7.0
+
 REM -----------------------------------------------------------------------------------------------------------------------
 Private Function _GetResultSetColumnValue(poResultSet As Object _
 											, ByVal piColIndex As Integer _
@@ -326,6 +365,15 @@ Dim sComponents() As String, sSubComponents() As String
 	
 End Function	'	FinalProperty
 
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function _GetEventName(ByVal psProperty As String) As String
+'	Return the LO internal event name
+'	Corrects the typo on ErrorOccur(r?)ed
+
+	_GetEventName = Replace(LCase(Mid(psProperty, 3, 1)) & Right(psProperty, Len(psProperty) - 3), "errorOccurred", "errorOccured")
+	
+End Function	'	_GetEventName	V1.7.0
+
 REM -----------------------------------------------------------------------------------------------------------------------
 Public Function _GetProductName(ByVal Optional psFlag As String) as String
 'Return OO product ("PRODUCT") and version numbers ("VERSION")
@@ -418,6 +466,7 @@ Public Function _hasUNOMethod(pvObject As Variant, psMethod As String) As Boolea
 
 Dim vInspect as Variant
 	_hasUNOMethod = False
+	If IsNull(pvObject) Then Exit Function
 	On Local Error Resume Next
 	vInspect = _A2B_.Introspection.Inspect(pvObject)
 	_hasUNOMethod = vInspect.hasMethod(psMethod, com.sun.star.beans.MethodConcept.ALL)
@@ -431,6 +480,7 @@ Public Function _hasUNOProperty(pvObject As Variant, psProperty As String) As Bo
 
 Dim vInspect as Variant
 	_hasUNOProperty = False
+	If IsNull(pvObject) Then Exit Function
 	On Local Error Resume Next
 	vInspect = _A2B_.Introspection.Inspect(pvObject)
 	_hasUNOProperty = vInspect.hasProperty(psProperty, com.sun.star.beans.PropertyConcept.ALL)
@@ -779,6 +829,51 @@ Error_Function:
 	Resume Exit_Function
 End Function	'	_ReadFileIntoArray	V1.4.0
 
+REM -----------------------------------------------------------------------------------------------------------------------
+Function _RegisterEventScript(poObject As Object _
+								, ByVal psEvent As String _
+								, ByVal psListener As String _
+								, ByVal psScriptCode As String _
+								, ByVal psName As String _
+								, Optional ByVal pbExtendName As Boolean _
+								) As Boolean
+'	Register a script event (psEvent) to poObject (Form, SubForm or Control)
+
+Dim i As Integer, oEvent As Object, sEvent As String, oParent As Object, iIndex As Integer, sName As String
+
+	_RegisterEventScript = False
+	If Not _hasUNOMethod(poObject, "getParent") Then Exit Function
+
+	'	Find object internal index i.e. how to reach it via getByIndex() 
+	If IsMissing(pbExtendName) Then pbExtendName = False
+	Set oParent = poObject.getParent()
+	iIndex = -1
+	For i = 0 To oParent.getCount() - 1
+		sName = oParent.getByIndex(i).Name
+		If (sName = psName) Or (pbExtendName And (sName = "MainForm" Or sName = "Form")) Then
+			iIndex = i
+			Exit For
+		End If
+	Next i
+	If iIndex < 0 Then Exit Function
+
+	sEvent = Utils._GetEventName(psEvent)			'	Targeted event method
+	If psScriptCode = "" Then
+		oParent.revokeScriptEvent(iIndex, psListener, sEvent, "")
+	Else
+		Set oEvent = CreateUnoStruct("com.sun.star.script.ScriptEventDescriptor")
+		With oEvent
+			.ListenerType = psListener
+			.EventMethod = sEvent
+			.ScriptType = "Script"			'	Better than "Basic"
+			.ScriptCode = psScriptCode
+		End With
+		oParent.registerScriptEvent(iIndex, oEvent)
+	End If
+	_RegisterEventScript = True
+
+End Function	'	_RegisterEventScript	V1.7.0
+
 REM -----------------------------------------------------------------------------------------------------------------------
 Public Sub _ResetCalledSub(ByVal psSub As String)
 '	Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling

wizards/source/access2base/acConstants.xba

@@ -8,7 +8,7 @@ REM ============================================================================
 Option Explicit
 
 REM Access2Base -----------------------------------------------------
-Global Const Access2Base_Version = "1.6.0"
+Global Const Access2Base_Version = "1.7.0"
 
 REM AcCloseSave
 REM -----------------------------------------------------------------