wizards/Package_access2base.mk | 1 wizards/source/access2base/Application.xba | 89 +++++++++++- wizards/source/access2base/Collect.xba | 117 ++++++++++++++-- wizards/source/access2base/Dialog.xba | 4 wizards/source/access2base/Event.xba | 5 wizards/source/access2base/L10N.xba | 2 wizards/source/access2base/PropertiesGet.xba | 26 ++- wizards/source/access2base/PropertiesSet.xba | 5 wizards/source/access2base/TempVar.xba | 191 +++++++++++++++++++++++++++ wizards/source/access2base/Utils.xba | 12 + wizards/source/access2base/script.xlb | 3 11 files changed, 411 insertions(+), 44 deletions(-)
New commits: commit 58192e3f7529af877b935f2cd390b8ddaf00459f Author: Jean-Pierre Ledure <[email protected]> Date: Sun Oct 5 18:03:17 2014 +0200 Access2Base - New TempVars collection and TempVar objects TempVar objects contain variables (name/value pair) that can be dynamically created and removed by macros. They're useful to transmit values from one document to another, e.g. an .odb document and one or more non-Base documents. Change-Id: I2cb5b3e27620eda16bdeaf59788b80c393fe7d9c diff --git a/wizards/Package_access2base.mk b/wizards/Package_access2base.mk index 2f551c1..7471d1c 100644 --- a/wizards/Package_access2base.mk +++ b/wizards/Package_access2base.mk @@ -45,6 +45,7 @@ $(eval $(call gb_Package_add_files,wizards_basicsrvaccess2base,$(LIBO_SHARE_FOLD Recordset.xba \ script.xlb \ SubForm.xba \ + TempVar.xba \ Test.xba \ Trace.xba \ Utils.xba \ diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba index 3dbf894..14a2fdd 100644 --- a/wizards/source/access2base/Application.xba +++ b/wizards/source/access2base/Application.xba @@ -86,6 +86,7 @@ Global Const COLLPROPERTIES = "PROPERTIES" Global Const COLLQUERYDEFS = "QUERYDEFS" Global Const COLLRECORDSETS = "RECORDSETS" Global Const COLLTABLEDEFS = "TABLEDEFS" +Global Const COLLTEMPVARS = "TEMPVARS" REM ----------------------------------------------------------------------------------------------------------------------- Global Const OBJAPPLICATION = "APPLICATION" @@ -102,6 +103,7 @@ Global Const OBJQUERYDEF = "QUERYDEF" Global Const OBJRECORDSET = "RECORDSET" Global Const OBJSUBFORM = "SUBFORM" Global Const OBJTABLEDEF = "TABLEDEF" +Global Const OBJTEMPVAR = "TEMPVAR" REM ----------------------------------------------------------------------------------------------------------------------- Global Const CTLCONTROL = "CONTROL" ' ClassId @@ -152,6 +154,7 @@ Type Root FindRecord As Object StatusBar As Object Dialogs As Object ' Collection + TempVars As Object ' Collection CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents End Type @@ -1131,6 +1134,60 @@ Error_Arg: End Function ' SysCmd V0.9.1 REM ----------------------------------------------------------------------------------------------------------------------- +Public Function TempVars(ByVal Optional pvIndex As Variant) As Variant +' Return either a Collection or a TempVar object + + If _ErrorHandler() Then On Local Error Goto Error_Function +Const cstThisSub = "TempVars" + Utils._SetCalledSub(cstThisSub) + +Dim iMode As Integer, vTempVars As Variant, bFound As Boolean +Const cstCount = 0 +Const cstByIndex = 1 +Const cstByName = 2 + + If IsMissing(pvIndex) Then + iMode = cstCount + Else + If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function + If VarType(pvIndex) = vbString Then iMode = cstByName Else iMode = cstByIndex + End If + + Set vTempVars = Nothing + Select Case iMode + Case cstCount ' Build Collection object + Set vTempVars = New Collect + With vTempVars + ._CollType = COLLTEMPVARS + ._Count = _A2B_.TempVars.Count + End With + Case cstByIndex ' Build TempVar object + If pvIndex < 0 Or pvIndex >= _A2B_.TempVars.Count Then Goto Trace_Error_Index + Set vTempVars = _A2B_.TempVars.Item(pvIndex + 1) ' Builtin collections start at 1 + Case cstByName + bFound = _hasItem(COLLTEMPVARS, pvIndex) + If Not bFound Then Goto Trace_NotFound + vTempVars = _A2B_.TempVars.Item(UCase(pvIndex)) + End Select + + Set TempVars = vTempVars + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Trace_Error_Index: + TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1) + Set vTempVars = Nothing + Goto Exit_Function +Trace_NotFound: + TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TEMPVAR"), pvIndex)) + Goto Exit_Function +End Function ' TempVars V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- Public Function Version() As String Version = Utils._GetProductName() End Function ' Version V0.9.1 @@ -1226,10 +1283,12 @@ Const cstBase = "com.sun.star.comp.dba.ODatabaseDocument" With .CurrentDoc(0) If Not .Active Then GoTo Trace_Error If IsNull(.Document) Then GoTo Trace_Error + If Not Utils._hasUNOProperty(ThisComponent, "URL") Then Goto Trace_Error If Utils._ImplementationName(ThisComponent) <> cstBase Or .Document.URL <> ThisComponent.URL Then ' Give the parent a try If Not Utils._hasUNOProperty(ThisComponent, "Parent") Then Goto Trace_Error If IsNull(ThisComponent.Parent) Then Goto Trace_Error If Utils._ImplementationName(ThisComponent.Parent) <> cstBase Then Goto Trace_Error + If Not Utils._hasUNOProperty(ThisComponent.Parent, "URL") Then Goto Trace_Error If .Document.URL <> ThisComponent.Parent.URL Then Goto Trace_Error End If End With @@ -1246,20 +1305,28 @@ Trace_Error: End Function ' _CurrentDoc V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Function _hasDialog(ByVal psName As String) As Boolean -' Return True if psName if in the collection of started dialogs +Public Function _hasItem(psCollType As String, ByVal psName As String) As Boolean +' Return True if psName if in the collection -Dim oDialog As Object +Dim oItem As Object On Local Error Goto Error_Function ' Whatever ErrorHandler ! - Set oDialog = _A2B_.Dialogs.Item(UCase(psName)) - _hasDialog = True + + _hasItem = True + Select Case psCollType + Case COLLALLDIALOGS + Set oItem = _A2B_.Dialogs.Item(UCase(psName)) + Case COLLTEMPVARS + Set oItem = _A2B_.TempVars.Item(UCase(psName)) + Case Else + _hasItem = False + End Select Exit_Function: Exit Function Error_Function: ' Item by key aborted - _hasDialog = False + _hasItem = False GoTo Exit_Function -End Function ' _hasDialog V1.1.0 +End Function ' _hasItem V1.2.0 REM ----------------------------------------------------------------------------------------------------------------------- Private Function _NewBar() As Object @@ -1297,11 +1364,12 @@ Dim vBar As Variant, vWindow As Variant, vController As Object End Function ' _NewBar V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- -Public Sub _RootInit() -' Initialize _A2B_ global variable +Public Sub _RootInit(Optional ByVal pbForce As Boolean) +' Initialize _A2B_ global variable. Reinit forced if pbForce = True Dim vRoot As Root, vCurrentDoc() As Variant - If IsEmpty(_A2B_) Then + If IsMissing(pbForce) Then pbForce = False + If IsEmpty(_A2B_) Or pbForce Then _A2B_ = vRoot With _A2B_ .VersionNumber = Access2Base_Version @@ -1316,6 +1384,7 @@ Dim vRoot As Root, vCurrentDoc() As Variant Set .FindRecord = Nothing Set .StatusBar = Nothing Set .Dialogs = New Collection + Set .TempVars = New Collection vCurrentDoc() = Array() ReDim vCurrentDoc(0 To 0) Set vCurrentDoc(0) = Nothing diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba index 34feab0..ebbf6fc 100644 --- a/wizards/source/access2base/Collect.xba +++ b/wizards/source/access2base/Collect.xba @@ -88,7 +88,7 @@ Dim vNames() As Variant, oProperty As Object Case COLLFIELDS Select Case _ParentType Case OBJQUERYDEF - Set Item = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem) ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + Set Item = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem) Case OBJRECORDSET Set Item = _ParentDatabase.Recordsets(_ParentName).Fields(pvItem) Case OBJTABLEDEF @@ -129,10 +129,13 @@ Dim vNames() As Variant, oProperty As Object Set Item = _ParentDatabase.Recordsets(pvItem) Case COLLTABLEDEFS Set Item = _ParentDatabase.TableDefs(pvItem) + Case COLLTEMPVARS + Set Item = Application.TempVars(pvItem) Case Else End Select Exit_Function: + Utils._ResetCalledSub(cstThisSub) Exit Property Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) @@ -170,21 +173,23 @@ REM ---------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- -Public Function Add(Optional pvObject As Variant) As Boolean -' Append a new TableDef or Field object to the TableDefs/Fields collections +Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean +' Append a new TableDef or TempVar object to the TableDefs/TempVars collections Const cstThisSub = "Collection.Add" Utils._SetCalledSub(cstThisSub) If _ErrorHandler() Then On Local Error Goto Error_Function -Dim odbDatabase As Object, oConnection As Object, oTables As Object, sName As String, oTable As Object +Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object +Dim vObject As Variant, oTempVar As Object Add = False - If IsMissing(pvObject) Then Call _TraceArguments() - If Not Utils._CheckArgument(pvObject, 1, vbObject) Then Goto Exit_Function + If IsMissing(pvNew) Then Call _TraceArguments() - With pvObject - Select Case ._Type - Case OBJTABLEDEF + Select Case _CollType + Case COLLTABLEDEFS + If Not Utils._CheckArgument(pvObject, 1, vbObject) Then Goto Exit_Function + Set vObject = pvNew + With vObject Set odbDatabase = ._ParentDatabase If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable Set oConnection = odbDatabase.Connection @@ -196,11 +201,21 @@ Dim odbDatabase As Object, oConnection As Object, oTables As Object, sName As St Set .TableDescriptor = Nothing .TableFieldsCount = 0 .TableKeysCount = 0 - Case Else - Goto Error_NotApplicable - End Select - End With + End With + Case COLLTEMPVARS + If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function + If pvNew = "" Then Goto Error_Name + If IsMissing(pvValue) Then Call _TraceArguments() + If Application._hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name + Set oTempVar = New TempVar + oTempVar._Name = pvNew + oTempVar._Value = pvValue + _A2B_.TempVars.Add(oTempVar, UCase(pvNew)) + Case Else + Goto Error_NotApplicable + End Select + _Count = _Count + 1 Add = True Exit_Function: @@ -213,7 +228,11 @@ Error_NotApplicable: TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) Goto Exit_Function Error_Sequence: - TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, pvObject._Name) + TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, vObject._Name) + Goto Exit_Function +Error_Name: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew)) + AddItem = False Goto Exit_Function End Function ' Add V1.1.0 @@ -247,6 +266,7 @@ Dim odbDatabase As Object, oColl As Object, vName As Variant Goto Error_NotApplicable End Select + _Count = _Count - 1 Delete = True Exit_Function: @@ -284,6 +304,73 @@ Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- +Public Function Remove(ByVal Optional pvName As Variant) As Boolean +' Remove a TempVar from the TempVars collection + +Const cstThisSub = "Collection.Remove" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + +Dim oColl As Object, vName As Variant + Remove = False + If IsMissing(pvName) Then pvName = "" + If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function + If pvName = "" Then Call _TraceArguments() + + Select Case _CollType + Case COLLTEMPVARS + If Not _hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name + _A2B_.TempVars.Remove(UCase(pvName)) + Case Else + Goto Error_NotApplicable + End Select + + _Count = _Count - 1 + Remove = True + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +Error_Name: + TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName)) + AddItem = False + Goto Exit_Function +End Function ' Remove V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function RemoveAll() As Boolean +' Remove the whole TempVars collection + +Const cstThisSub = "Collection.Remove" + Utils._SetCalledSub(cstThisSub) + If _ErrorHandler() Then On Local Error Goto Error_Function + + Select Case _CollType + Case COLLTEMPVARS + Set _A2B_.TempVars = New Collection + _Count = 0 + Case Else + Goto Error_NotApplicable + End Select + +Exit_Function: + Utils._ResetCalledSub(cstThisSub) + Exit Function +Error_Function: + TraceError(TRACEABORT, Err, cstThisSub, Erl) + GoTo Exit_Function +Error_NotApplicable: + TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub) + Goto Exit_Function +End Function ' RemoveAll V1.2.0 + +REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant @@ -320,6 +407,4 @@ Error_Function: _PropertyGet = Nothing GoTo Exit_Function End Function ' _PropertyGet - - </script:module> \ No newline at end of file diff --git a/wizards/source/access2base/Dialog.xba b/wizards/source/access2base/Dialog.xba index 7847438..00ba51e 100644 --- a/wizards/source/access2base/Dialog.xba +++ b/wizards/source/access2base/Dialog.xba @@ -487,7 +487,7 @@ Dim oStart As Object Start = True Set UnoDialog = oStart With _A2B_ - If Application._hasDialog(_Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate + If Application._hasItem(COLLALLDIALOGS, _Name) Then .Dialogs.Remove(_Name) ' Inserted to solve errors, when aborts between start and terminate .Dialogs.Add(UnoDialog, UCase(_Name)) End With End If @@ -574,7 +574,7 @@ Dim vEMPTY As Variant Case UCase("Height") _PropertyGet = UnoDialog.getPosSize().Height Case UCase("IsLoaded") - _PropertyGet = Application._hasDialog(_Name) + _PropertyGet = Application._hasItem(COLLALLDIALOGS, _Name) Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") diff --git a/wizards/source/access2base/Event.xba b/wizards/source/access2base/Event.xba index 73bcd82..ddf37aa 100644 --- a/wizards/source/access2base/Event.xba +++ b/wizards/source/access2base/Event.xba @@ -404,12 +404,13 @@ Dim sXPos As String, sYPos As String sXPos = Iif(IsNull(_XPos), "", "XPos") sYPos = Iif(IsNull(_YPos), "", "YPos") - _PropertiesList = Utils._TrimArray("ButtonLeft", "ButtonRight", "ButtonMiddle", "ClickCount" _ + _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 diff --git a/wizards/source/access2base/L10N.xba b/wizards/source/access2base/L10N.xba index b5f99a0..3ec24d2 100644 --- a/wizards/source/access2base/L10N.xba +++ b/wizards/source/access2base/L10N.xba @@ -84,6 +84,7 @@ Dim sLocal As String Case "REPORT" : sLocal = "Report" Case "RECORDSET" : sLocal = "Recordset" Case "FIELD" : sLocal = "Field" + Case "TEMPVAR" : sLocal = "Temporary variable" '---------------------------------------------------------------------------------------------------------------------- Case "ERR#" : sLocal = "Error #" Case "ERROCCUR" : sLocal = "occurred" @@ -188,6 +189,7 @@ Dim sLocal As String Case "REPORT" : sLocal = "Rapport" Case "RECORDSET" : sLocal = "Recordset" Case "FIELD" : sLocal = "Champ" + Case "TEMPVAR" : sLocal = "Variable temporaire" '---------------------------------------------------------------------------------------------------------------------- Case "ERR#" : sLocal = "L'erreur #" Case "ERROCCUR" : sLocal = "s'est produite" diff --git a/wizards/source/access2base/PropertiesGet.xba b/wizards/source/access2base/PropertiesGet.xba index e5bee5f..d4df22c 100644 --- a/wizards/source/access2base/PropertiesGet.xba +++ b/wizards/source/access2base/PropertiesGet.xba @@ -394,7 +394,8 @@ Const cstEXCLAMATION = "!" Const cstDOT = "." If _ErrorHandler() Then On Local Error Goto Error_Function - Utils._SetCalledSub("getObject") +Const cstThisSub = "getObject" + Utils._SetCalledSub(cstThisSub) If IsMissing(pvShortcut) Then Call _TraceArguments() If Not Utils._CheckArgument(pvShortcut, 1, vbString) Then Goto Exit_Function @@ -404,7 +405,7 @@ Dim oDoc As Object Set vCurrentObject = Nothing sComponents = Split(Trim(pvShortcut), cstEXCLAMATION) If UBound(sComponents) = 0 Then Goto Trace_Error - If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS")) Then Goto Trace_Error + If Not Utils._InList(UCase(sComponents(0)), Array("FORMS", "DIALOGS", "TEMPVARS")) Then Goto Trace_Error If sComponents(1) = "0" Or Left(sComponents(1), 2) = "0." Then Set oDoc = _A2B_.CurrentDoc(Application._CurrentDoc()) If oDoc.DbConnect = DBCONNECTFORM Then sComponents(1) = oDoc.DbContainers(0).FormName Else Goto Trace_Error @@ -417,6 +418,7 @@ Dim oDoc As Object Select Case UCase(sComponents(0)) Case "FORMS" : vCurrentObject._CollType = COLLFORMS Case "DIALOGS" : vCurrentObject._CollType = COLLALLDIALOGS + Case "TEMPVARS" : vCurrentObject._CollType = COLLTEMPVARS End Select For iCurrentIndex = 1 To UBound(sComponents) ' Start parsing ... sSubComponents = Split(sComponents(iCurrentIndex), cstDOT) @@ -439,6 +441,9 @@ Dim oDoc As Object vCurrentObject = Application.AllDialogs(sDialog) If Not vCurrentObject.IsLoaded Then Goto Trace_Error Set vCurrentObject.UnoDialog = _A2B_.Dialogs.Item(sDialog) + Case COLLTEMPVARS + If UBound(sComponents) > 1 Then Goto Trace_Error + vCurrentObject = Application.TempVars(sComponents(1)) 'Case Else End Select Case OBJFORM, OBJSUBFORM, OBJCONTROL, OBJDIALOG @@ -450,13 +455,13 @@ Dim oDoc As Object Set getObject = vCurrentObject Exit_Function: - Utils._ResetCalledSub("getObject") + Utils._ResetCalledSub(cstThisSub) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvShortcut)) Goto Exit_Function Error_Function: - TraceError(TRACEABORT, Err, "getObject", Erl) + TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' getObject V0.9.5 @@ -733,6 +738,9 @@ Public Function _getProperty(pvItem As Variant, ByVal psProperty As String, ByVa Utils._SetCalledSub("get" & psProperty) _getProperty = Nothing +'pvItem must be an object and have the requested property + If Not Utils._CheckArgument(pvItem, 1, vbObject) Then Goto Exit_Function + If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error 'Check Index argument If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 3, Utils._AddNumeric()) Then Goto Exit_Function @@ -916,18 +924,18 @@ Public Function _getProperty(pvItem As Variant, ByVal psProperty As String, ByVa Case UCase("Locked") If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function If IsNull(pvItem.Locked) Then Goto Trace_Error - _getProperty = pvItem.Locked + _ge ExitProperty = pvItem.Locked Case UCase("MultiSelect") If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function _getProperty = pvItem.MultiSelect Case UCase("Name") If Not Utils._CheckArgument(pvItem, 1, _ - Array(OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJDIALOG, OBJTABLEDEF, OBJRECORDSET, OBJFIELD) _ + Array(OBJFORM, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJDIALOG, OBJTABLEDEF, OBJRECORDSET, OBJFIELD, OBJTEMPVAR) _ ) Then Goto Exit_Function _getProperty = pvItem.Name Case UCase("ObjectType") If Not Utils._CheckArgument(pvItem, 1, Array(OBJDATABASE, OBJCOLLECTION, OBJFORM, OBJDIALOG, OBJSUBFORM, OBJCONTROL _ - , OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY, OBJRECORDSET, OBJTABLEDEF, OBJFIELD) _ + , OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY, OBJRECORDSET, OBJTABLEDEF, OBJFIELD, OBJTEMPVAR) _ ) Then Goto Exit_Function _getProperty = pvItem.ObjectType Case UCase("OpenArgs") @@ -1021,7 +1029,7 @@ Public Function _getProperty(pvItem As Variant, ByVal psProperty As String, ByVa If Not Utils._CheckArgument(pvItem, 1, OBJFIELD) Then Goto Exit_Function _getProperty = pvItem.TypeName Case UCase("Value") - If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJFIELD)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJPROPERTY, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function _getProperty = pvItem.Value Case UCase("Visible") If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function @@ -1159,7 +1167,7 @@ Dim i As Integer, j As Integer, iCount As Integer Set vProperties = Nothing Select Case pvObject._Type Case OBJCOLLECTION, OBJPROPERTY, OBJFORM, OBJEVENT, OBJSUBFORM, OBJCONTROL, OBJOPTIONGROUP _ - , OBJDATABASE, OBJTABLEDEF, OBJQUERYDEF, OBJDIALOG, OBJFIELD, OBJRECORDSET + , OBJDATABASE, OBJTABLEDEF, OBJQUERYDEF, OBJDIALOG, OBJFIELD, OBJRECORDSET, OBJTEMPVAR vPropertiesList = pvObject._PropertiesList() Case Else End Select diff --git a/wizards/source/access2base/PropertiesSet.xba b/wizards/source/access2base/PropertiesSet.xba index c6422cd..d60c3ce 100644 --- a/wizards/source/access2base/PropertiesSet.xba +++ b/wizards/source/access2base/PropertiesSet.xba @@ -375,6 +375,8 @@ Private Function _setProperty(pvItem As Variant, ByVal psProperty As String, ByV Utils._SetCalledSub("set" & psProperty) If _ErrorHandler() Then On Local Error Goto Error_Function +'pvItem must be an object and have the requested property + If Not Utils._CheckArgument(pvIndex, 1, vbObject) Then Goto Exit_Function 'Check Index argument If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 4, Utils._AddNumeric()) Then Goto Exit_Function @@ -386,6 +388,7 @@ Dim odbDatabase As Object, vNames As Variant, bFound As Boolean, sName As String Dim ocButton As Variant, iRadioIndex As Integer _setProperty = True If _A2B_.CalledSub = "setProperty" Then iArgNr = 3 Else iArgNr = 2 + If Not PropertiesGet._hasProperty(pvItem._Type, pvItem._PropertiesList(), psProperty) Then Goto Trace_Error_Control Select Case UCase(psProperty) Case UCase("AbsolutePosition") If Not Utils._CheckArgument(pvItem, 1, OBJRECORDSET) Then Goto Exit_Function @@ -529,7 +532,7 @@ Dim ocButton As Variant, iRadioIndex As Integer If Not Utils._CheckArgument(pvItem, 1, OBJCONTROL) Then Goto Exit_Function pvItem.TripleState = pvValue Case UCase("Value") - If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJFIELD)) Then Goto Exit_Function + If Not Utils._CheckArgument(pvItem, 1, Array(OBJCONTROL, OBJOPTIONGROUP, OBJFIELD, OBJTEMPVAR)) Then Goto Exit_Function pvItem.Value = pvValue Case UCase("Visible") If Not Utils._CheckArgument(pvItem, 1, Array(OBJFORM, OBJDIALOG, OBJCONTROL)) Then Goto Exit_Function diff --git a/wizards/source/access2base/TempVar.xba b/wizards/source/access2base/TempVar.xba new file mode 100644 index 0000000..f3230ed --- /dev/null +++ b/wizards/source/access2base/TempVar.xba @@ -0,0 +1,191 @@ +<?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="TempVar" 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 TEMPVAR +Private _Name As String +Private _Value As Variant + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CONSTRUCTORS / DESTRUCTORS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Sub Class_Initialize() + _Type = OBJTEMPVAR + _Name = "" + _Value = Null +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 Name() As String + Name = _PropertyGet("Name") +End Property ' Name (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get ObjectType() As String + ObjectType = _PropertyGet("ObjectType") +End Property ' ObjectType (get) + +REM ----------------------------------------------------------------------------------------------------------------------- +Property Get Value() As Variant + Value = _PropertyGet("Value") +End Property ' Value (get) + +Property Let Value(ByVal pvValue As Variant) + Call _PropertySet("Value", pvValue) +End Property ' Value (set) + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- CLASS METHODS --- +REM ----------------------------------------------------------------------------------------------------------------------- + +Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant +' Return property value of psProperty property name + + Utils._SetCalledSub("Property.getProperty") + If IsMissing(pvProperty) Then Call _TraceArguments() + getProperty = _PropertyGet(pvProperty) + Utils._ResetCalledSub("Property.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 ----------------------------------------------------------------------------------------------------------------------- +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, _Name, vPropertiesList) + Else + vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex) + vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) + End If + +Exit_Function: + Set Properties = vProperty + Exit Function +End Function ' Properties + +REM ----------------------------------------------------------------------------------------------------------------------- +Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean +' Return True if property setting OK +Dim cstThisSub As String + cstThisSub = Utils._PCase(_Type) & ".getProperty" + Utils._SetCalledSub(cstThisSub) + setProperty = _PropertySet(psProperty, pvValue) + Utils._ResetCalledSub(cstThisSub) +End Function + +REM ----------------------------------------------------------------------------------------------------------------------- +REM --- PRIVATE FUNCTIONS --- +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertiesList() As Variant + _PropertiesList = Array("Name", "ObjectType", "Value") +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("TempVar.get" & psProperty) + _PropertyGet = Nothing + + Select Case UCase(psProperty) + Case UCase("Name") + _PropertyGet = _Name + Case UCase("ObjectType") + _PropertyGet = _Type + Case UCase("Value") + _PropertyGet = _Value + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("TempVar.get" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertyGet = Nothing + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "TempVar._PropertyGet", Erl) + _PropertyGet = Nothing + GoTo Exit_Function +End Function ' _PropertyGet + +REM ----------------------------------------------------------------------------------------------------------------------- +Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean + + Utils._SetCalledSub("TempVar.set" & psProperty) + If _ErrorHandler() Then On Local Error Goto Error_Function + _PropertySet = True + +'Execute +Dim iArgNr As Integer + + If Len(_A2B_.CalledSub) > 8 And Left(_A2B_.CalledSub, 8) = "TempVar." Then iArgNr = 1 Else iArgNr = 2 + Select Case UCase(psProperty) + Case UCase("Value") + _Value = pvValue + _A2B_.TempVars.Item(UCase(_Name)).Value = pvValue + Case Else + Goto Trace_Error + End Select + +Exit_Function: + Utils._ResetCalledSub("TempVar.set" & psProperty) + Exit Function +Trace_Error: + TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) + _PropertySet = False + Goto Exit_Function +Trace_Error_Value: + TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) + _PropertySet = False + Goto Exit_Function +Error_Function: + TraceError(TRACEABORT, Err, "TempVar._PropertySet", Erl) + _PropertySet = False + GoTo Exit_Function +End Function ' _PropertySet +</script:module> \ No newline at end of file diff --git a/wizards/source/access2base/Utils.xba b/wizards/source/access2base/Utils.xba index 5a9b302..ace29d9 100644 --- a/wizards/source/access2base/Utils.xba +++ b/wizards/source/access2base/Utils.xba @@ -103,6 +103,7 @@ Dim iVarType As Integer If VarType(pvItem) = vbCurrency Or VarType(pvItem) = vbDecimal Or VarType(pvItem) = vbBigint Then pvItem = CDbl(pvItem) Exit_Function: +Const cstObject = "[com.sun.star.script.NativeObjectWrapper]" If Not _CheckArgument Then If IsMissing(pvError) Then pvError = True If pvError Then @@ -502,8 +503,8 @@ Dim oDoc As Object, oForms As Variant If ._DbConnect = DBCONNECTFORM Then bPseudoExists = True Else bPseudoExists = .Document.CurrentController.IsConnected Case OBJDIALOG If ._Name <> "" Then ' Check validity of dialog name - bPseudoExists = ( Application._hasDialog(._Name) ) - End If + bPseudoExists = ( Application._hasItem(COLLALLDIALOGS, ._Name) ) + End If Case OBJCOLLECTION bPseudoExists = True Case OBJCONTROL @@ -532,6 +533,10 @@ Dim oDoc As Object, oForms As Variant bPseudoExists = ( Not IsNull(.RowSet) ) Case OBJFIELD bPseudoExists = ( ._Name <> "" And Not IsNull(.Column) ) + Case OBJTEMPVAR + If ._Name <> "" Then ' Check validity of tempvar name + bPseudoExists = ( Application._hasItem(COLLTEMPVARS, ._Name) ) + End If Case Else End Select End With @@ -592,6 +597,7 @@ REM ---------------------------------------------------------------------------- Public Sub _ResetCalledSub(ByVal psSub As String) As String ' Called in bottom of each public function. _A2B_.CalledSub variable is used for error handling ' Used to trace routine in/outs and to clarify error messages + If IsEmpty(_A2B_) Then Call Application._RootInit() ' Only is Utils module recompiled If _A2B_.CalledSub = psSub Then _A2B_.CalledSub = "" If _A2B_.MinimalTraceLevel = 1 Then TraceLog(TRACEDEBUG, _GetLabel("Exiting") & " " & psSub & " ...", False) End Sub ' ResetCalledSub @@ -665,7 +671,7 @@ Dim sTrim As String, vTrim() As Variant, i As Integer, j As Integer, iCount As I Next i End If End If - + _TrimArray() = vTrim() End Function ' TrimArray V0.9.0 diff --git a/wizards/source/access2base/script.xlb b/wizards/source/access2base/script.xlb index 7bc8a9c..78efee9 100644 --- a/wizards/source/access2base/script.xlb +++ b/wizards/source/access2base/script.xlb @@ -25,4 +25,5 @@ <library:element library:name="Field"/> <library:element library:name="DataDef"/> <library:element library:name="Recordset"/> -</library:library> \ No newline at end of file + <library:element library:name="TempVar"/> +</library:library> _______________________________________________ Libreoffice-commits mailing list [email protected] http://lists.freedesktop.org/mailman/listinfo/libreoffice-commits
