[Libreoffice-commits] core.git: wizards/source
Jean-Pierre Ledure
jp at ledure.be
Tue May 13 05:30:30 PDT 2014
wizards/source/access2base/Application.xba | 660 +++++++++++++++++----------
wizards/source/access2base/Collect.xba | 142 ++++-
wizards/source/access2base/Control.xba | 258 +++++++---
wizards/source/access2base/DataDef.xba | 164 +++++-
wizards/source/access2base/Database.xba | 530 +++++++++++++++++++--
wizards/source/access2base/Dialog.xba | 32 -
wizards/source/access2base/DoCmd.xba | 496 ++++++++++++++------
wizards/source/access2base/Event.xba | 50 --
wizards/source/access2base/Field.xba | 50 +-
wizards/source/access2base/Form.xba | 160 +++---
wizards/source/access2base/L10N.xba | 36 -
wizards/source/access2base/Methods.xba | 107 ++--
wizards/source/access2base/OptionGroup.xba | 10
wizards/source/access2base/PropertiesGet.xba | 10
wizards/source/access2base/PropertiesSet.xba | 38 +
wizards/source/access2base/Property.xba | 7
wizards/source/access2base/Recordset.xba | 76 ++-
wizards/source/access2base/SubForm.xba | 36 -
wizards/source/access2base/Test.xba | 20
wizards/source/access2base/Trace.xba | 29 -
wizards/source/access2base/Utils.xba | 153 +++---
wizards/source/access2base/acConstants.xba | 5
22 files changed, 2215 insertions(+), 854 deletions(-)
New commits:
commit e6c21ee479b7dbfa11398b8038d7abc26d47f98b
Author: Jean-Pierre Ledure <jp at ledure.be>
Date: Sat May 10 16:01:47 2014 +0200
Access2Base new release - V1.1.0
Access2Base library can be run to access a database defined in any form stored
in any AOO/LibO document. Now CurrentDb method may be associated with a form
object, not only with the root class.The OpenDatabase method allows any
AOO/LibO document to get access to tables stored in any database.
RunSQL, OpenSQL, database functions have been extended to be run from
a database object, not only as a command. The CopyObject (new) action copies
query definitions and/or table definitions and data.
Creation of table and fields without SQL with the CreateTableDef, CreateField
and Append methods. The Description property of a TableDef is writable.
New GetHiddenAttribute and SetHiddenAttribute actions hide or show any
AOO/LibO or Base object. SelectObject scope has been extended accordingly.
Addition of the SelStart, SelLength and SelText properties for text controls.
Change-Id: I163f3bcb0f63dc346e1bd23729356ebe556c6592
Reviewed-on: https://gerrit.libreoffice.org/9303
Reviewed-by: Lionel Elie Mamane <lionel at mamane.lu>
Tested-by: Lionel Elie Mamane <lionel at mamane.lu>
diff --git a/wizards/source/access2base/Application.xba b/wizards/source/access2base/Application.xba
index 3497669..9de68cd 100644
--- a/wizards/source/access2base/Application.xba
+++ b/wizards/source/access2base/Application.xba
@@ -7,10 +7,6 @@ REM ============================================================================
Option Explicit
-'DATABASE
-' Name property
-' Path property
-
REM -----------------------------------------------------------------------------------------------------------------------
Global Const TRACEDEBUG = "DEBUG" ' To report values of variables
Global Const TRACEINFO = "INFO" ' To report any event
@@ -23,12 +19,12 @@ Global Const TRACEANY = "===>" ' Always reported
' FATALs and ABORTs interrupt the program execution
Global Const ERRINIT = 1500
-Global Const ERRNOTDATABASE = 1501
-Global Const ERRDBNOTCONNECTED = 1502
-Global Const ERRMISSINGARGUMENTS = 1503
-Global Const ERRWRONGARGUMENT = 1504
-Global Const ERRMAINFORM = 1505
-Global Const ERRSTANDALONE = 1506
+Global Const ERRDBNOTCONNECTED = 1501
+Global Const ERRMISSINGARGUMENTS = 1502
+Global Const ERRWRONGARGUMENT = 1503
+Global Const ERRMAINFORM = 1504
+Global Const ERRMETHOD = 1505
+Global Const ERRFILEACCESS = 1506
Global Const ERRFORMNOTIDENTIFIED = 1507
Global Const ERRFORMNOTFOUND = 1508
Global Const ERRFORMNOTOPEN = 1509
@@ -49,31 +45,36 @@ Global Const ERRSQLSTATEMENT = 1523
Global Const ERROBJECTNOTFOUND = 1524
Global Const ERROPENOBJECT = 1525
Global Const ERRCLOSEOBJECT = 1526
-Global Const ERRMETHOD = 1527
Global Const ERRACTION = 1528
Global Const ERRSENDMAIL = 1529
Global Const ERRFORMYETOPEN = 1530
-Global Const ERRMETHOD = 1531
-Global Const ERRPROPERTYINIT = 1532
-Global Const ERRFILENOTCREATED = 1533
-Global Const ERRDIALOGNOTFOUND = 1534
-Global Const ERRDIALOGUNDEFINED = 1535
-Global Const ERRDIALOGSTARTED = 1536
-Global Const ERRDIALOGNOTSTARTED = 1537
-Global Const ERRRECORDSETNODATA = 1538
-Global Const ERRRECORDSETCLOSED = 1539
-Global Const ERRRECORDSETRANGE = 1540
-Global Const ERRRECORDSETFORWARD = 1541
-Global Const ERRFIELDNULL = 1542
-Global Const ERRFILEACCESS = 1543
-Global Const ERRMEMOLENGTH = 1544
-Global Const ERRNOTACTIONQUERY = 1545
-Global Const ERRNOTUPDATABLE = 1546
-Global Const ERRUPDATESEQUENCE = 1547
-Global Const ERRNOTNULLABLE = 1548
-Global Const ERRROWDELETED = 1549
-Global Const ERRRECORDSETCLONE = 1550
-Global Const ERRQUERYDEFDELETED = 1551
+Global Const ERRPROPERTYINIT = 1531
+Global Const ERRFILENOTCREATED = 1532
+Global Const ERRDIALOGNOTFOUND = 1533
+Global Const ERRDIALOGUNDEFINED = 1534
+Global Const ERRDIALOGSTARTED = 1535
+Global Const ERRDIALOGNOTSTARTED = 1536
+Global Const ERRRECORDSETNODATA = 1537
+Global Const ERRRECORDSETCLOSED = 1538
+Global Const ERRRECORDSETRANGE = 1539
+Global Const ERRRECORDSETFORWARD = 1540
+Global Const ERRFIELDNULL = 1541
+Global Const ERRMEMOLENGTH = 1542
+Global Const ERRNOTACTIONQUERY = 1543
+Global Const ERRNOTUPDATABLE = 1544
+Global Const ERRUPDATESEQUENCE = 1545
+Global Const ERRNOTNULLABLE = 1546
+Global Const ERRROWDELETED = 1547
+Global Const ERRRECORDSETCLONE = 1548
+Global Const ERRQUERYDEFDELETED = 1549
+Global Const ERRTABLEDEFDELETED = 1550
+Global Const ERRTABLECREATION = 1551
+Global Const ERRFIELDCREATION = 1552
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Global Const DBCONNECTBASE = 1 ' Connection from Base document (OpenConnection)
+Global Const DBCONNECTFORM = 2 ' Connection from a database-aware form (OpenConnection)
+Global Const DBCONNECTANY = 3 ' Connection from any document for data access only (OpenDatabase)
REM -----------------------------------------------------------------------------------------------------------------------
Global Const COLLALLDIALOGS = "ALLDIALOGS"
@@ -139,7 +140,6 @@ Global Const CTLPARENTISGROUP = "OPTIONGROUP"
REM -----------------------------------------------------------------------------------------------------------------------
Type Root
- ' Single values
ErrorHandler As Boolean
MinimalTraceLevel As Integer
TraceLogs() As Variant
@@ -149,7 +149,22 @@ Type Root
CalledSub As String
Introspection As Object ' com.sun.star.beans.Introspection
VersionNumber As String ' Actual Access2Base version number
- CurrentDb() As Object ' Array of database objects -{0] = Base file, [1..N] = Writer files
+ FindRecord As Object
+ StatusBar As Object
+ Dialogs As Object ' Collection
+ CurrentDoc() As Variant ' Array of document containers - [0] = Base document, [1 ... N] = other documents
+End Type
+
+Type DocContainer
+ Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
+ DbConnect As Integer ' DBCONNECTxxx constants
+ URL As String
+ DbContainers() As Variant ' One entry by (data-aware) form
+End Type
+
+Type DbContainer
+ FormName As String ' name of data-aware form
+ Database As Object ' Database type
End Type
REM -----------------------------------------------------------------------------------------------------------------------
@@ -173,19 +188,19 @@ Const cstSepar = "!"
If IsMissing(pvIndex) Then
iMode = cstCount
Else
- If Not Utils.Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ 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 vAllDialogs = Nothing
- Set oDocLibraries = ThisComponent.DialogLibraries '_CurrentDb().Document.DialogLibraries
+ Set oDocLibraries = ThisComponent.DialogLibraries
vDocLibraries = oDocLibraries.getElementNames()
Set oMacLibraries = DialogLibraries
vMacLibraries = oMacLibraries.getElementNames()
'Remove Access2Base from the list
For i = 0 To UBound(vMacLibraries)
- If vMacLibraries(i) = "Access2Base" Then vMacLibraries(i) = ""
+ If Left(vMacLibraries(i), 11) = "Access2Base" Then vMacLibraries(i) = ""
Next i
vMacLibraries = Utils._TrimArray(vMacLibraries)
@@ -258,7 +273,7 @@ Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Not_Found:
- TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils.Utils._CalledSub(), 0, , pvIndex)
+ TraceError(TRACEFATAL, ERRDIALOGNOTFOUND, Utils._CalledSub(), 0, , pvIndex)
Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
@@ -283,7 +298,7 @@ Dim iIndex As Integer, vAllForms As Variant
Set vAllForms = Nothing
If Not IsMissing(pvIndex) Then
- If Not Utils.Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
Select Case VarType(pvIndex)
Case vbString
iIndex = -1
@@ -292,16 +307,21 @@ Dim iIndex As Integer, vAllForms As Variant
End Select
End If
-Dim oDatabase As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object
- Set oDatabase = _CurrentDb()
- If Not oDatabase._Standalone Then Set oForms = oDatabase.Document.getFormDocuments()
+Dim iCurrentDoc As Integer, vCurrentDoc As Variant, oForms As Variant, oCounter As Variant, oFormsCollection As Object
+ iCurrentDoc = Application._CurrentDoc()
+ If iCurrentDoc >= 0 Then
+ vCurrentDoc = _A2B_.CurrentDoc(iCurrentDoc)
+ Else
+ Goto Exit_Function
+ End If
+ If vCurrentDoc.DbConnect = DBCONNECTBASE Then Set oForms = vCurrentDoc.Document.getFormDocuments()
' Process when NO ARGUMENT
If IsMissing(pvIndex) Then ' No argument
Set oCounter = New Collect
oCounter._CollType = COLLALLFORMS
oCounter._ParentType = OBJAPPLICATION
oCounter._ParentName = ""
- If oDatabase._Standalone Then oCounter._Count = 1 Else oCounter._Count = oForms.getCount()
+ If vCurrentDoc.DbConnect = DBCONNECTFORM Then oCounter._Count = UBound(vCurrentDoc.DbContainers) + 1 Else oCounter._Count = oForms.getCount()
Set vAllForms = oCounter
Goto Exit_Function
End If
@@ -309,25 +329,43 @@ Dim oDatabase As Variant, oForms As Variant, oCounter As Variant, oFormsCollecti
' Process when ARGUMENT = STRING or INDEX => Initialize form object
Dim ofForm As Object
Set ofForm = New Form
-Dim sAllForms As Variant, i As Integer, sSub As String, vName As Variant
- Select Case oDatabase._Standalone
- Case False
+ Set ofForm._This = ofForm
+Dim sAllForms As Variant, i As Integer, vName As Variant, oDatabase As Object, bFound As Boolean
+ Select Case vCurrentDoc.DbConnect
+ Case DBCONNECTBASE
sAllForms() = oForms.getElementNames()
- If iIndex= -1 Then ' String argument
- vName = Utils._InList(Utils.Utils._Trim(pvIndex), sAllForms, True) ' hasByName not used because case sensitive
+ ofForm._DocEntry = 0
+ ofForm._DbEntry = 0
+ If iIndex= -1 Then ' String argument
+ vName = Utils._InList(Utils._Trim(pvIndex), sAllForms, True) ' hasByName not used because case sensitive
If vName = False Then Goto Trace_Not_Found
ofForm._Initialize(vName)
Else
If iIndex + 1 > oForms.getCount() Or iIndex < 0 Then Goto Trace_Error_Index ' Numeric argument OK but value nonsense
ofForm._Initialize(sAllForms(iIndex))
End If
- Case True
- If iIndex = -1 Then
- If UCase(Utils.Utils._Trim(pvIndex)) <> UCase(oDatabase.FormName) Then Goto Trace_Not_Found
- ElseIf iIndex <> 0 Then
- Goto Trace_Error_Index
- End If
+ Case DBCONNECTFORM
+ With vCurrentDoc
+ If iIndex = -1 Then
+ bFound = False
+ For i = 0 To UBound(vCurrentDoc.DbContainers)
+ Set oDatabase = vCurrentDoc.DbContainers(i).Database
+ If UCase(Utils._Trim(pvIndex)) = UCase(oDatabase.FormName) Then
+ bFound = True
+ ofForm._DbEntry = i
+ Exit For
+ End If
+ Next i
+ If Not bFound Then Goto Trace_Not_Found
+ ElseIf iIndex < 0 Or iIndex > UBound(vCurrentDoc.DbContainers) Then
+ Goto Trace_Error_Index
+ Else
+ ofForm._DbEntry = iIndex
+ Set oDatabase = vCurrentDoc.DbContainers(iIndex).Database
+ End If
+ End With
vName = oDatabase.FormName
+ ofForm._DocEntry = iCurrentDoc
ofForm._Initialize(vName)
End Select
@@ -382,7 +420,7 @@ Const cstThisSub = "Controls"
If IsMissing(pvIndex) Then
Controls = vObject.Controls()
Else
- If Not Utils._CheckArgument(pvIndex, 2, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ If Not Utils._CheckArgument(pvIndex, 2, Utils._AddNumeric(vbString)) Then Goto Exit_Function
Controls = vObject.Controls(pvIndex)
End If
@@ -396,44 +434,26 @@ End Function ' Controls V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentDb(Optional pvURL As String) As Object
-' Returns _A2B_.CurrentDb(.) as an object to allow access to its properties
+' Returns _A2B_.CurrentDoc(.).Database as an object to allow access to its properties
' Parameter only for internal use
Const cstThisSub = "CurrentDb"
Utils._SetCalledSub(cstThisSub)
-Dim i As Integer, bFound As Boolean, sURL As String, oCurrent As Object
+Dim i As Integer, bFound As Boolean, sURL As String, iCurrentDoc As Integer, oCurrentDoc As Object
bFound = False
Set CurrentDb = Nothing
With _A2B_
- If Not IsArray(.CurrentDb) Then Goto Exit_Function
- If UBound(.CurrentDb) < 0 Then Goto Exit_Function
- For i = 1 To UBound(.CurrentDb) ' [0] reserved to database .odb document
- Set oCurrent = .CurrentDb(i)
- If IsMissing(pvURL) Then ' Not on 1 single line ?!?
- If Utils.Utils._hasUNOProperty(ThisComponent, "URL") Then
- sURL = ThisComponent.URL
- Else
- Exit For ' f.i. ThisComponent = Basic IDE ...
- End If
- Else
- sURL = pvURL ' To support the SelectObject action
- End If
- If .CurrentDb(i).URL = sURL Then
- Set CurrentDb = oCurrent
- bFound = True
- Exit For
- End If
- Next i
- If Not bFound Then
- If Not IsNull(.CurrentDb(0)) Then Set CurrentDb = .CurrentDb(0)
- End If
+ If Not IsArray(.CurrentDoc) Then Goto Exit_Function
+ If UBound(.CurrentDoc) < 0 Then Goto Exit_Function
+ iCurrentDoc = _CurrentDoc()
+ If iCurrentDoc >= 0 Then Set CurrentDb = .CurrentDoc(iCurrentDoc).DbContainers(0).Database
End With
Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
-End Function ' CurrentDb V0.9.5
+End Function ' CurrentDb V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function CurrentUser() As String
@@ -461,7 +481,7 @@ Public Function DAvg( _
Const cstThisSub = "DAvg"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DAvg = Application._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DAvg = Application._CurrentDb()._DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DAvg
@@ -475,7 +495,7 @@ Public Function DCount( _
Const cstThisSub = "DCount"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DCount = Application._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DCount = Application._CurrentDb()._DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DCount
@@ -503,7 +523,7 @@ Public Function DLookup( _
Const cstThisSub = "DLookup"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DLookup = Application._DFunction("", psExpr, psDomain _
+ DLookup = Application._CurrentDb()._DFunction("", psExpr, psDomain _
, Iif(IsMissing(pvCriteria), "", pvCriteria) _
, Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
)
@@ -520,7 +540,7 @@ Public Function DMax( _
Const cstThisSub = "DMax"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DMax = Application._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DMax = Application._CurrentDb()._DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DMax
@@ -534,7 +554,7 @@ Public Function DMin( _
Const cstThisSub = "DMin"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DMin = Application._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DMin = Application._CurrentDb()._DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DMin
@@ -548,7 +568,7 @@ Public Function DStDev( _
Const cstThisSub = "DStDev"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DStDev = Application._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
+ DStDev = Application._CurrentDb()._DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
Utils._ResetCalledSub(cstThisSub)
End Function ' DStDev
@@ -562,7 +582,7 @@ Public Function DStDevP( _
Const cstThisSub = "DStDevP"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DStDevP = Application._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
+ DStDevP = Application._CurrentDb()._DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
Utils._ResetCalledSub(cstThisSub)
End Function ' DStDevP
@@ -576,7 +596,7 @@ Public Function DSum( _
Const cstThisSub = "DSum"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DSum = Application._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DSum = Application._CurrentDb()._DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DSum
@@ -590,7 +610,7 @@ Public Function DVar( _
Const cstThisSub = "DVar"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DVar = Application._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DVar = Application._CurrentDb()._DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DVar
@@ -604,7 +624,7 @@ Public Function DVarP( _
Const cstThisSub = "DVarP"
Utils._SetCalledSub(cstThisSub)
If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
- DVarP = Application._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
+ DVarP = Application._CurrentDb()._DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
Utils._ResetCalledSub(cstThisSub)
End Function ' DVarP
@@ -621,7 +641,8 @@ Const cstThisSub = "Events"
If IsMissing(poEvent) Then Goto Exit_Function
If IsNull(poEvent) Then Goto Exit_Function
- If Not Utils.Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error
+ If Not Utils._CheckArgument(poEvent, 1, vbObject) Then Goto Exit_Function
+ If Not Utils._hasUNOProperty(poEvent, "Source") Then Goto Trace_Error
Set vEvent = New Event
vEvent._Initialize(poEvent)
@@ -634,7 +655,7 @@ Error_Function:
GoTo Exit_Function
Trace_Error:
' Errors are not displayed to avoid display infinite cycling
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Utils.Utils._CStr(poEvent))
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, False, Array(1, Utils._CStr(poEvent)))
Set vEvent = Nothing
Goto Exit_Function
End Function ' Events V0.9.1
@@ -663,12 +684,12 @@ Dim iCount As Integer
Forms = oCounter
Exit Function
Else
- If Not Utils._CheckArgument(pvIndex, 1, Utils.Utils._AddNumeric(vbString)) Then Goto Exit_Function
+ If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
End If
Select Case VarType(pvIndex)
Case vbString
- Set ofForm = Application.AllForms(Utils.Utils._Trim(pvIndex))
+ Set ofForm = Application.AllForms(Utils._Trim(pvIndex))
Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbBigint, vbDecimal
iCount = Application._CountOpenForms()
If iCount <= pvIndex Then Goto Trace_Error_Index
@@ -690,7 +711,7 @@ Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Trace_Error:
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1)
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvIndex))
Set vForms = Nothing
Goto Exit_Function
Trace_Error_Index:
@@ -703,119 +724,262 @@ Error_Function:
End Function ' Forms V0.9.0
REM -----------------------------------------------------------------------------------------------------------------------
-Public Sub OpenConnection ( _
+Public Function OpenConnection ( _
Optional pvComponent As Variant _
, ByVal Optional pvUser As Variant _
, ByVal Optional pvPassword As Variant _
- )
+ ) As Object
' Establish connection with the database designated in the currently open front-end (.odb) document
' Call template:
' Call OpenConnection(ThisDatabaseDocument[, "", ""])
' Call stored in the OpenDocument event of the front-end database document
'OR
-' Initiates processing of a standalone (Writer) form (V0.8.0)
+' Initiates processing of a (standalone ?) Writer, Calc, ... document with 1 or more data-aware forms
' Call template:
' Call OpenConnection(ThisComponent[, "", ""])
-' Call stored in the OpenDocument event of the standalone form
+' Call stored in the OpenDocument event of the document
+'
+' User and Password arguments are obsolete (still tolerated)
+' - because no mean has been found to connect protected db from .odb via API
+' - because having multiple forms with multiple db's and multiple passwords is meaningless
-Dim odbDatabase As Variant, oComponent As Object, oForm As Object, iCurrent As Integer
+Dim oComponent As Object, oForms As Object, iCurrent As Integer
Dim i As Integer, bFound As Boolean
-Dim vCurrentDb() As Variant
+Dim vCurrentDoc() As Variant
+Dim oBaseContext As Object, sDbNames() As String, oBaseSource As Object
+Dim sDatabaseURL As String, oHandler As Object
+Dim vDbContainer As Variant, vDbContainers() As Variant, vDocContainer As Variant
+Dim sFormName As String, oConnection As Object
If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
+ Set OpenConnection = Nothing
- If _ErrorHandler() Then On Local Error Goto Error_Sub
+ If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "OpenConnection"
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvComponent) Then Call _TraceArguments()
- If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Sub
+ If Not Utils._CheckArgument(pvComponent, 1, vbObject) Then Goto Exit_Function
Set oComponent = pvComponent
If Not Utils._hasUNOProperty(oComponent, "ImplementationName") Then
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, 1)
- Exit Sub
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, 1, Array(1, oComponent))
+ Exit Function
End If
If IsMissing(pvUser) Then pvUser = ""
If IsMissing(pvPassword) Then pvPassword = ""
- If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Sub
- If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Sub
-
- If Not IsArray(_A2B_.CurrentDb) Then vCurrentDb = Array() Else vCurrentDb = _A2B_.CurrentDb
+ If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
+ If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
- Set odbDatabase = New Database
+ If Not IsArray(_A2B_.CurrentDoc) Then
+ vCurrentDoc() = Array()
+ Redim vCurrentDoc(0 To 0) ' Create at least one entry for database document
+ Else
+ vCurrentDoc() = _A2B_.CurrentDoc()
+ End If
+
+ ' Find index of entry to use for new connection
+ With oComponent
+ Select Case .ImplementationName
+ Case "com.sun.star.comp.dba.ODatabaseDocument"
+ iCurrent = 0
+ Case Else ' "SwXTextDocument", "ScModelObj"
+ If UBound(vCurrentDoc) <= 0 Then ' First Calc or Writer during current session
+ iCurrent = 1
+ Else ' Search entry already used earlier by same component
+ bFound = False
+ For i = 1 To UBound(vCurrentDoc)
+ If Not IsEmpty(vCurrentDoc(i)) Then
+ If vCurrentDoc(i).URL = .URL Then
+ iCurrent = i
+ bFound = True
+ Exit For
+ End If
+ End If
+ Next i
+ End If
+ If Not bFound Then
+ iCurrent = UBound(vCurrentDoc) + 1 ' No entry found, increment array
+ ReDim Preserve vCurrentDoc(0 To iCurrent)
+ End If
+ End Select
+ End With
+
+ ' Initialize future entry
+ Set vDocContainer = New DocContainer
+ Set vDocContainer.Document = oComponent
+ vDocContainer.URL = oComponent.URL
+ ' Initialize each DbContainer entry
+ vDbContainers() = Array()
+ TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
Select Case oComponent.ImplementationName
- Case "com.sun.star.comp.dba.ODatabaseDocument"
- If Not oComponent.CurrentController.IsConnected Then oComponent.CurrentController.Connect(pvUser, pvPassword)
- Set odbDatabase.Connection = oComponent.CurrentController.ActiveConnection
- odbDatabase._Standalone = False
- Case "SwXTextDocument"
- Set oForm = oComponent.CurrentController.Model.DrawPage.Forms
- If oForm.Count <> 1 Then Goto Error_MainForm
- odbDatabase.FormName = oForm.ElementNames(0)
- odbDatabase.Form = oForm.getByName(odbDatabase.FormName)
- Set odbDatabase.Connection = odbDatabase.Form.ActiveConnection
- odbDatabase._Standalone = True
+ Case "com.sun.star.comp.dba.ODatabaseDocument" ' Ignore pvUser and pvPassword arguments
+ vDbContainer = New DbContainer
+ vDbContainer.FormName = ""
+ Set vDbContainer.Database = New Database
+ Set vDbContainer.Database._This = vDbContainer.Database
+ With vDbContainer.Database
+ If Not oComponent.CurrentController.IsConnected Then
+ Set oHandler = createUnoService("com.sun.star.sdb.InteractionHandler")
+ Set .Connection = oComponent.DataSource.connectWithCompletion(oHandler)
+ oComponent.CurrentController.connect()
+ Else
+ Set .Connection = oComponent.CurrentController.ActiveConnection
+ End If
+ vDocContainer.DbConnect = DBCONNECTBASE
+ ._DbConnect = DBCONNECTBASE
+ Set .MetaData = .Connection.MetaData
+ ._ReadOnly = .Connection.isReadOnly()
+ Set .Document = oComponent
+ .Title = oComponent.Title
+ .URL = vDocContainer.URL
+ ReDim vDbContainers(0 To 0)
+ Set vDbContainers(0) = vDbContainer
+ TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False)
+ TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL, False)
+ End With
Case Else
- TraceError(TRACEFATAL, ERRNOTDATABASE, Utils._CalledSub(), 0, , 1)
- End Select
+ Set oForms = oComponent.CurrentController.Model.DrawPage.Forms
+ If oForms.Count < 1 Then Goto Error_MainForm
+ ReDim vDbContainers(0 To oForms.Count - 1)
+ For i = 0 To oForms.Count - 1
+ vDbContainer = New DbContainer ' To make distinct entries !!
+ sFormName = oForms.ElementNames(i)
+ Set oConnection = oForms.getByName(sFormName).ActiveConnection
+ If IsNull(oConnection) Then
+ Set vDbContainer.Database = Nothing ' Form is not data-aware
+ Else
+ Set vDbContainer.Database = New Database
+ Set vDbContainer.Database._This = vDbContainer.Database
+ With vDbContainer.Database
+ .FormName = sFormName
+ vDbContainer.FormName = sFormName
+ Set .Form = oForms.getByName(sFormName)
+ Set .Connection = oConnection
+ Set .MetaData = oConnection.MetaData
+ ._ReadOnly = oConnection.isReadOnly()
+ Set .Document = oComponent
+ .Title = oComponent.Title
+ .URL = .Form.DataSourceName
+ ._DbConnect = DBCONNECTFORM
+ Set vDbContainers(i) = vDbContainer
+ vDbContainers(i).FormName = sFormName
+ TraceLog(TRACEANY, .MetaData.getDatabaseProductName() & " " & .MetaData.getDatabaseProductVersion, False)
+ TraceLog(TRACEANY, UCase(cstThisSub) & " " & .URL & " Form=" & vDbContainer.FormName, False)
+ End With
+ End If
+ Next i
+ vDocContainer.DbConnect = DBCONNECTFORM
+ End Select
+
+ vDocContainer.DbContainers() = vDbContainers()
+ Set vCurrentDoc(iCurrent) = vDocContainer
+
+ _A2B_.CurrentDoc = vCurrentDoc
+ Set OpenConnection = vDbContainers(0).Database
+
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+Error_Function:
+ TraceError(TRACEABORT, Err, cstThisSub, Erl)
+ Set _A2B_.CurrentDoc = Array()
+ GoTo Exit_Function
+Error_MainForm:
+ TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title)
+ Set _A2B_.CurrentDoc = Array()
+ GoTo Exit_Function
+Trace_Error:
+ TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
+ Goto Exit_Function
+End Function ' OpenConnection V1.1.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function OpenDatabase ( _
+ ByVal Optional pvDatabaseURL As Variant _
+ , ByVal Optional pvUser As Variant _
+ , ByVal Optional pvPassword As Variant _
+ , ByVal Optional pvReadOnly As Variant _
+ ) As Object
+
+' Return a database object based on input arguments:
+' Call template:
+' Call OpenConnection("... databaseURL ..."[, "", "", True/False])
+' pvDatabaseURL maby be the name of a registered database or the URL of the targeted .odb file
+' Might be called from any AOO/LibO application, independently from OpenConnection
+
+Dim odbDatabase As Variant, oBaseContext As Object, sDbNames() As String, oBaseSource As Object
+Dim i As Integer, bFound As Boolean
+Dim sDatabaseURL As String
+
+ If IsEmpty(_A2B_) Then Call Application._RootInit() ' First use of Access2Base in current AOO/LibO session
+ Set OpenDatabase = Nothing
+
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+Const cstThisSub = "OpenDatabase"
+ Utils._SetCalledSub(cstThisSub)
+ If pvDatabaseURL = "" Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvDatabaseURL, 1, vbString) Then Goto Exit_Function
+ If IsMissing(pvUser) Then pvUser = ""
+ If IsMissing(pvPassword) Then pvPassword = ""
+ If Not Utils._CheckArgument(pvUser, 2, vbString) Then Goto Exit_Function
+ If Not Utils._CheckArgument(pvPassword, 3, vbString) Then Goto Exit_Function
+ If IsMissing(pvReadOnly) Then pvReadOnly = False
+ If Not Utils._CheckArgument(pvReadOnly, 3, vbBoolean) Then Goto Exit_Function
+ Set odbDatabase = New Database
+ Set odbDatabase._This = odbDatabase
+ odbDatabase._DbConnect = DBCONNECTANY
+
+ Set oBaseContext = CreateUnoService("com.sun.star.sdb.DatabaseContext")
+ sDbNames() = oBaseContext.getElementNames()
+ bFound = False
+ For i = 0 To UBound(sDbNames() ' Enumerate registered databases and check non case-sensitive equality
+ If UCase(sDbNames(i)) = UCase(pvDatabaseURL) Then
+ sDatabaseURL = sDbNames(i)
+ Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
+ bFound = True
+ Exit For
+ End If
+ Next i
+ If Not bFound Then
+ sDatabaseURL = ConvertToURL(pvDatabaseURL)
+ If UCase(Right(sDatabaseURL, 4)) <> ".ODB" Then Goto Trace_Error
+ If Not FileExists(sDatabaseURL) Then Goto Trace_Error
+ Set oBaseSource = oBaseContext.getByName(sDatabaseURL)
+ End If
+
+ Set odbDatabase.Connection = oBaseSource.getConnection(pvUser, pvPassword)
If Not IsNull(odbDatabase.Connection) Then ' Null when standalone and target db does not exist
Set odbDatabase.MetaData = odbDatabase.Connection.MetaData
+ Else
+ Goto Trace_Error
End If
- Set odbDatabase.Document = oComponent
- odbDatabase.Title = oComponent.Title
- odbDatabase.URL = oComponent.URL
+
+ odbDatabase.URL = sDatabaseURL
- If UBound(vCurrentDb) < 0 Then ' NOT ON 1 SINGLE LINE !!!
- Redim vCurrentDb(0 To 0)
+ If pvReadOnly Then
+ odbDatabase.Connection.isReadOnly = True
+ odbDatabase._ReadOnly = True
End If
- Select Case odbDatabase._Standalone ' Find entry to use for new connection
- Case True
- If UBound(vCurrentDb) <= 0 Then
- iCurrent = 1
- Else ' Search entry already used earlier by same component
- bFound = False
- For i = 1 To UBound(vCurrentDb)
- If Not IsEmpty(vCurrentDb(i)) Then
- If vCurrentDb(i)._Standalone And vCurrentDb(i).URL = odbDatabase.URL Then
- iCurrent = i
- bFound = True
- Exit For
- End If
- End If
- Next i
- End If
- If Not bFound Then
- iCurrent = UBound(vCurrentDb) + 1 ' No entry found, increment array
- ReDim Preserve vCurrentDb(0 To iCurrent)
- End If
- Set vCurrentDb(iCurrent) = odbDatabase
- Case False
- Set vCurrentDb(0) = odbDatabase
- End Select
+ Set OpenDatabase = odbDatabase
- _A2B_.CurrentDb = vCurrentDb
-
- TraceLog(TRACEANY, Utils._GetProductName() & " - Access2Base " & _A2B_.VersionNumber, False)
- If IsNull(odbDatabase.Connection) Then Goto Trace_Error
+ TraceLog(TRACEANY, Utils._GetProductName() & " - " & Application.ProductCode(), False)
TraceLog(TRACEANY, odbDatabase.MetaData.getDatabaseProductName() & " " & odbDatabase.MetaData.getDatabaseProductVersion, False)
+ TraceLog(TRACEANY, UCase(cstThisSub) & " " & odbDatabase.URL, False)
+
-Exit_Sub:
+Exit_Function:
Utils._ResetCalledSub(cstThisSub)
- Exit Sub
-Error_Sub:
+ Exit Function
+Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
- Set _A2B_.CurrentDb = Array()
- GoTo Exit_Sub
-Error_MainForm:
- TraceError(TRACEFATAL, ERRMAINFORM, Utils._CalledSub(), False, ,oComponent.Title)
- Set _A2B_.CurrentDb = Array()
- GoTo Exit_Sub
+ GoTo Exit_Function
Trace_Error:
TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
- Goto Exit_Sub
-End Sub ' OpenConnection V0.9.1
+ Goto Exit_Function
+End Function ' OpenDatabase V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProductCode()
@@ -838,7 +1002,7 @@ Const cstThisSub = "SysCmd"
Const cstMissing = -1
Const cstBarLength = 350
If IsMissing(pvAction) Then Call _TraceArguments()
- If Not Utils._CheckArgument(pvAction, 1, Utils.Utils._AddNumeric(), Array( _
+ If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric(), Array( _
acSysCmdAccessDir _
, acSysCmdAccessVer _
, acSysCmdClearHelpTopic _
@@ -854,7 +1018,7 @@ Const cstBarLength = 350
, acSysCmdUpdateMeter _
)) Then Goto Exit_Function
If IsMissing(pvValue) Then pvValue = cstMissing
- If Not Utils._CheckArgument(pvAction, 1, Utils.Utils._AddNumeric()) Then Goto Exit_Function
+ If Not Utils._CheckArgument(pvAction, 1, Utils._AddNumeric()) Then Goto Exit_Function
Select Case pvAction
Case acSysCmdInitMeter, acSysCmdUpdateMeter, acSysCmdSetStatus
If IsMissing(pvText) Then Call _TraceArguments()
@@ -863,9 +1027,8 @@ Const cstBarLength = 350
End Select
If Not Utils._CheckArgument(pvValue, 3, Utils._AddNumeric()) Then Goto Exit_Function
-Dim vBar As Variant, oDb As Object, iLen As Integer
- Set oDb = _CurrentDb()
- Set vBar = oDb.StatusBar
+Dim vBar As Variant, iLen As Integer
+ Set vBar = _A2B_.StatusBar
Select Case pvAction
Case acSysCmdAccessVer
SysCmd = Application.Version()
@@ -879,7 +1042,7 @@ Dim vBar As Variant, oDb As Object, iLen As Integer
If pvValue <> cstMissing Then Goto Error_Arg
If Not IsNull(vBar) Then
vBar.end()
- Set oDb.StatusBar = Nothing
+ Set _A2B_.StatusBar = Nothing
End If
Case acSysCmdInitMeter
If pvValue = cstMissing Then Call _TraceArguments()
@@ -894,7 +1057,7 @@ Dim vBar As Variant, oDb As Object, iLen As Integer
Case acSysCmdRemoveMeter
If Not IsNull(vBar) Then
vBar.end()
- Set oDb.StatusBar = Nothing
+ Set _A2B_.StatusBar = Nothing
End If
Case acSysCmdRuntime
SysCmd = False
@@ -934,6 +1097,7 @@ Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant
iCount = 0
If iAllCount > 0 Then
Set ofForm = New Form
+ Set ofForm._This = ofForm
For i = 0 To iAllCount - 1
Set ofForm = Application.AllForms(i)
If ofForm.IsLoaded Then iCount = iCount + 1
@@ -948,103 +1112,106 @@ Dim i As Integer, iCount As Integer, iAllCount As Integer, ofForm As Variant
If IsMissing(piCountMax) Then _CountOpenForms = iCount
-End Function ' CountOpenForms V0.9.0
+End Function ' CountOpenForms V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
-Public Function _CurrentDb() As Variant
-REM Same as CurrentDb() except that it generates an error if database not connected (internal use)
+Public Function _CurrentDb(ByVal Optional piDocEntry As Integer, ByVal Optional piDbEntry As Integer) As Variant
+REM Without arguments same as CurrentDb() except that it generates an error if database not connected (internal use)
+REM With 2 arguments return the corresponding entry in Root
Dim odbDatabase As Variant
- Set odbDatabase = Application.CurrentDb()
+ If IsMissing(piDocEntry) Then
+ Set odbDatabase = Application.CurrentDb()
+ Else
+ With _A2B_
+ If Not IsArray(.CurrentDoc) Then Goto Trace_Error
+ If piDocEntry < 0 Or piDbEntry < 0 Then Goto Trace_Error
+ If piDocEntry > UBound(.CurrentDoc) Then Goto Trace_Error
+ If piDbEntry > UBound(.CurrentDoc(piDocEntry).DbContainers) Then Goto Trace_Error
+ Set odbDatabase = .CurrentDoc(piDocEntry).DbContainers(piDbEntry).Database
+ End With
+ End If
If IsNull(odbDatabase) Then GoTo Trace_Error
Exit_Function:
Set _CurrentDb = odbDatabase
Exit Function
Trace_Error:
- TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0,1)
+ TraceError(TRACEABORT, ERRDBNOTCONNECTED, Utils._CalledSub(), 0, 1)
Goto Exit_Function
-End Function ' _CurrentDb
+End Function ' _CurrentDb V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
-Private Function _DFunction(ByVal psFunction As String _
- , ByVal psExpr As String _
- , ByVal psDomain As String _
- , ByVal pvCriteria As Variant _
- , ByVal Optional pvOrderClause As Variant _
- ) As Variant
- 'Arguments: psFunction an optional aggregate function
- ' psExpr: an SQL expression [might contain an aggregate function]
- ' psDomain: a table- or queryname
- ' pvCriteria: an optional WHERE clause
- ' pcOrderClause: an optional order clause incl. "DESC" if relevant
+Public Function _CurrentDoc(Optional pvURL As String) As Integer
+' Returns the entry in _A2B_.CurrentDoc(...) referring to the current document
+
+Dim i As Integer, bFound As Boolean, sURL As String
+
+ bFound = False
+ _CurrentDoc = -1 ' Convention for _A2B_ not initalized or no entry found
+ With _A2B_
+ If Not IsArray(.CurrentDoc) Then Goto Exit_Function
+ If UBound(.CurrentDoc) < 0 Then Goto Exit_Function
+ For i = 1 To UBound(.CurrentDoc) ' [0] reserved to database .odb document
+ If IsMissing(pvURL) Then ' Not on 1 single line ?!?
+ If Utils._hasUNOProperty(ThisComponent, "URL") Then
+ sURL = ThisComponent.URL
+ Else
+ Exit For ' f.i. ThisComponent = Basic IDE ...
+ End If
+ Else
+ sURL = pvURL ' To support the SelectObject action
+ End If
+ If .CurrentDoc(i).URL = sURL Then
+ _CurrentDoc = i
+ bFound = True
+ Exit For
+ End If
+ Next i
+ If Not bFound Then
+ If Not IsNull(.CurrentDoc(0)) Then _CurrentDoc = 0
+ End If
+ End With
-If _ErrorHandler() Then On Local Error GoTo Error_Function
-
-Dim oResult As Object 'To retrieve the value to find.
-Dim vResult As Variant 'Return value for function.
-Dim sSql As String 'SQL statement.
-Dim oStatement As Object 'For CreateStatement method
-Dim sExpr As String 'For inclusion of aggregate function
-
- vResult = Null
-
- If psFunction = "" Then sExpr = "TOP 1 " & psExpr Else sExpr = UCase(psFunction) & "(" & psExpr & ")"
-
- sSql = "SELECT " & sExpr & " AS XXRESULTFIELDXX FROM " & psDomain
- If pvCriteria <> "" Then
- sSql = sSql & " WHERE " & pvCriteria
- End If
- If pvOrderClause <> "" Then
- sSql = sSql & " ORDER BY " & pvOrderClause
- End If
- sSql = Utils._ReplaceSquareBrackets(sSql) 'Substitute [] by quote string
-
- 'Lookup the value.
-Dim oDatabase As Object
- Set oStatement = _CurrentDb.Connection.createStatement()
- With oStatement
- .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
- .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
- .EscapeProcessing = False
- Set oResult = .executeQuery(sSql)
- If Not IsNull(oResult) And Not IsEmpty(oResult) Then
- If Not oResult.next() Then Goto Exit_Function
- vResult = Utils._getResultSetColumnValue(oResult, 1)
- End If
- End With
+Exit_Function:
+ Exit Function
+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
+
+Dim oDialog As Object
+ On Local Error Goto Error_Function ' Whatever ErrorHandler !
+ Set oDialog = _A2B_.Dialogs.Item(UCase(psName))
+ _hasDialog = True
Exit_Function:
- 'Assign the returned value.
- _DFunction = vResult
- Set oResult = Nothing
- Set oStatement = Nothing
- Exit Function
-Error_Function:
- TraceError(TRACEABORT, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
- Goto Exit_Function
-End Function ' DFunction V0.9.5
+ Exit Function
+Error_Function: ' Item by key aborted
+ _hasDialog = False
+ GoTo Exit_Function
+End Function ' _hasDialog V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _NewBar() As Object
' Close current status bar, if any, and initialize new one
-Dim vBar As Variant, vWindow As Variant, oDb As Object, vController As Object
+Dim vBar As Variant, vWindow As Variant, vController As Object
On Local Error Resume Next
Set _NewBar = Nothing
- Set oDb = Application._CurrentDb()
- Set vBar = oDb.StatusBar
+ Set vBar = _A2B_.StatusBar
If Not IsNull(vBar) Then
If Utils._hasUNOMethod(vBar, "end") Then vBar.end()
- Set oDb.StatusBar = Nothing
+ Set _A2B_.StatusBar = Nothing
End If
Set vBar = Nothing
Set vWindow = _SelectWindow()
If IsNull(vWindow.Frame) Then Exit Function
Select Case vWindow.WindowType
- Case acForm, acReport, acBasicIDE ' Not found how to make it work for acDatabaseWindow
+ Case acForm, acReport, acBasicIDE, acDocument ' Not found how to make it work for acDatabaseWindow
Case Else
Exit Function
End Select
@@ -1055,17 +1222,17 @@ Dim vBar As Variant, vWindow As Variant, oDb As Object, vController As Object
End If
If Utils._hasUNOMethod(vController, "getStatusIndicator") Then vBar = vController.getStatusIndicator()
- Set oDb.StatusBar = vBar
+ Set _A2B_.StatusBar = vBar
Set _NewBar = vBar
Exit Function
-End Function ' _NewBar V0.9.1
+End Function ' _NewBar V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _RootInit()
' Initialize _A2B_ global variable
-Dim vRoot As Root
+Dim vRoot As Root, vCurrentDoc() As Variant
If IsEmpty(_A2B_) Then
_A2B_ = vRoot
With _A2B_
@@ -1078,8 +1245,15 @@ Dim vRoot As Root
.TraceLogMaxEntries = 0
.CalledSub = ""
.Introspection = Nothing
+ Set .FindRecord = Nothing
+ Set .StatusBar = Nothing
+ Set .Dialogs = New Collection
+ vCurrentDoc() = Array()
+ ReDim vCurrentDoc(0 To 0)
+ Set vCurrentDoc(0) = Nothing
+ Set .CurrentDoc() = vCurrentDoc()
End With
End If
-End Sub ' _RootInit V0.9.1
+End Sub ' _RootInit V1.1.0
</script:module>
\ No newline at end of file
diff --git a/wizards/source/access2base/Collect.xba b/wizards/source/access2base/Collect.xba
index 34abbfb..80c53a0 100644
--- a/wizards/source/access2base/Collect.xba
+++ b/wizards/source/access2base/Collect.xba
@@ -16,11 +16,12 @@ REM ----------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS ---
REM -----------------------------------------------------------------------------------------------------------------------
-Private _Type As String ' Must be COLLECTION
-Private _CollType As String
-Private _ParentType As String
-Private _ParentName As String ' Name or shortcut
-Private _Count As Long
+Private _Type As String ' Must be COLLECTION
+Private _CollType As String
+Private _ParentType As String
+Private _ParentName As String ' Name or shortcut
+Private _ParentDatabase As Object
+Private _Count As Long
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
@@ -51,7 +52,7 @@ Property Get Item(ByVal Optional pvItem As Variant) As Variant
Const cstThisSub = "Collection.getItem"
Utils._SetCalledSub(cstThisSub)
- If IsMissing(pvItem) Then Call _TraceArguments()
+ If IsMissing(pvItem) Then Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error
If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
Dim vNames() As Variant, oProperty As Object
@@ -78,47 +79,47 @@ Dim vNames() As Variant, oProperty As Object
Case COLLFIELDS
Select Case _ParentType
Case OBJQUERYDEF
- Set Item = Application.CurrentDb().QueryDefs(_ParentName).Fields(pvItem)
+ Set Item = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem) ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Case OBJRECORDSET
- Set Item = Application.CurrentDb().Recordsets(_ParentName).Fields(pvItem)
+ Set Item = _ParentDatabase.Recordsets(_ParentName).Fields(pvItem)
Case OBJTABLEDEF
- Set Item = Application.CurrentDb().TableDefs(_ParentName).Fields(pvItem)
+ Set Item = _ParentDatabase.TableDefs(_ParentName).Fields(pvItem)
End Select
Case COLLPROPERTIES
Select Case _ParentType
Case OBJCONTROL, OBJSUBFORM
Set Item = getObject(_ParentName).Properties(pvItem)
Case OBJDATABASE
- Set Item = Application.CurrentDb().Properties(pvItem)
+ Set Item = _ParentDatabase.Properties(pvItem)
Case OBJDIALOG
Set Item = Application.AllDialogs(_ParentName).Properties(pvItem)
Case OBJFIELD
vNames() = Split(_ParentName, "/")
Select Case vNames(0)
Case OBJQUERYDEF
- Set Item = Application.CurrentDb().QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
+ Set Item = _ParentDatabase.QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
Case OBJRECORDSET
- Set Item = Application.CurrentDb().Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem)
+ Set Item = _ParentDatabase.Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem)
Case OBJTABLEDEF
- Set Item = Application.CurrentDb().TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
+ Set Item = _ParentDatabase.TableDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
End Select
Case OBJFORM
Set Item = Application.Forms(_ParentName).Properties(pvItem)
Case OBJQUERYDEF
- Set Item = Application.CurrentDb().QueryDefs(_ParentName).Properties(pvItem)
+ Set Item = _ParentDatabase.QueryDefs(_ParentName).Properties(pvItem)
Case OBJRECORDSET
- Set Item = Application.CurrentDb().Recordsets(_ParentName).Properties(pvItem)
+ Set Item = _ParentDatabase.Recordsets(_ParentName).Properties(pvItem)
Case OBJTABLEDEF
- Set Item = Application.CurrentDb().TableDefs(_ParentName).Properties(pvItem)
- Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP
+ Set Item = _ParentDatabase.TableDefs(_ParentName).Properties(pvItem)
+ Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY
' NOT SUPPORTED
End Select
Case COLLQUERYDEFS
- Set Item = Application.CurrentDb().QueryDefs(pvItem)
+ Set Item = _ParentDatabase.QueryDefs(pvItem)
Case COLLRECORDSETS
- Set Item = Application.CurrentDb().Recordsets(pvItem)
+ Set Item = _ParentDatabase.Recordsets(pvItem)
Case COLLTABLEDEFS
- Set Item = Application.CurrentDb().TableDefs(pvItem)
+ Set Item = _ParentDatabase.TableDefs(pvItem)
Case Else
End Select
@@ -128,7 +129,7 @@ Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
Set Item = Nothing
GoTo Exit_Function
-End Property ' V0.9.5
+End Property ' V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
@@ -160,6 +161,100 @@ REM ----------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
+Public Function Append(Optional pvObject As Variant) As Boolean
+' Append a new TableDef or Field object to the TableDefs/Fields collections
+
+Const cstThisSub = "Collection.Append"
+ 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
+ Append = False
+ If IsMissing(pvObject) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvObject, 1, vbObject) Then Goto Exit_Function
+
+ With pvObject
+ Select Case ._Type
+ Case OBJTABLEDEF
+ Set odbDatabase = ._ParentDatabase
+ If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
+ Set oConnection = odbDatabase.Connection
+ If IsNull(.TableDescriptor) Or .TableFieldsCount = 0 Then Goto Error_Sequence
+ Set oTables = oConnection.getTables()
+ oTables.appendByDescriptor(.TableDescriptor)
+ Set .Table = oTables.getByName(._Name)
+ .TableDescriptor.dispose()
+ Set .TableDescriptor = Nothing
+ .TableFieldsCount = 0
+ .TableKeysCount = 0
+ Case Else
+ Goto Error_NotApplicable
+ End Select
+ End With
+
+ Append = 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_Sequence:
+ TraceError(TRACEFATAL, ERRTABLECREATION, Utils._CalledSub(), 0, 1, pvObject._Name)
+ Goto Exit_Function
+End Function ' Append V1.1.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Public Function Delete(ByVal Optional pvName As Variant) As Boolean
+' Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections
+
+Const cstThisSub = "Collection.Delete"
+ Utils._SetCalledSub(cstThisSub)
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+
+Dim odbDatabase As Object, oColl As Object, vName As Variant
+ Delete = 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 COLLTABLEDEFS, COLLQUERYDEFS
+ If Application._CurrentDoc <> 0 Then Goto Error_NotApplicable
+ Set odbDatabase = Application._CurrentDb()
+ If odbDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
+ If _CollType = COLLTABLEDEFS Then Set oColl = odbDatabase.Connection.getTables() Else Set oColl = odbDatabase.Connection.getQueries()
+ With oColl
+ vName = _InList(pvName, .getElementNames(), True)
+ If vName = False Then Goto trace_NotFound
+ .dropByName(vName)
+ End With
+ odbDatabase.Document.store()
+ Case Else
+ Goto Error_NotApplicable
+ End Select
+
+ Delete = 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
+Trace_NotFound:
+ TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel(Left(_CollType, 5)), pvName))
+ Goto Exit_Function
+End Function ' Delete V1.1.0
+
+REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name
@@ -183,7 +278,7 @@ REM ----------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
- _PropertiesList = Array("Count", "ObjectType")
+ _PropertiesList = Array("Count", "Item", "ObjectType")
End Function ' _PropertiesList
REM -----------------------------------------------------------------------------------------------------------------------
@@ -197,6 +292,7 @@ Private Function _PropertyGet(ByVal psProperty As String) As Variant
Select Case UCase(psProperty)
Case UCase("Count")
_PropertyGet = _Count
+ Case UCase("Item")
Case UCase("ObjectType")
_PropertyGet = _Type
Case Else
@@ -207,7 +303,7 @@ Exit_Function:
Utils._ResetCalledSub("Collection.get" & psProperty)
Exit Function
Trace_Error:
- TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
+ TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
diff --git a/wizards/source/access2base/Control.xba b/wizards/source/access2base/Control.xba
index 42ff713..7e15a1d 100644
--- a/wizards/source/access2base/Control.xba
+++ b/wizards/source/access2base/Control.xba
@@ -21,6 +21,8 @@ Private _ParentType As String ' One of CTLPARENTISxxxx constants
Private _Shortcut As String
Private _Name As String
Private _FormComponent As Object ' com.sun.star.text.TextDocument
+Private _DocEntry As Integer ' Doc- and DbContainer entries in Root structure
+Private _DbEntry As Integer
Private _ControlType As Integer
Private _SubType As String
Private ControlModel As Object ' com.sun.star.comp.forms.XXXModel
@@ -37,6 +39,9 @@ Private Sub Class_Initialize()
_ParentType = ""
_Shortcut = ""
_Name = ""
+ Set _FormComponent = Nothing
+ _DocEntry = -1
+ _DbEntry = -1
_SubType = ""
Set ControlModel = Nothing
Set ControlView = Nothing
@@ -358,6 +363,33 @@ Public Function SelectedI(ByVal pvValue As variant, ByVal pvIndex As Variant)
End Function
REM -----------------------------------------------------------------------------------------------------------------------
+Property Get SelLength() As Variant
+ SelLength = _PropertyGet("SelLength")
+End Property ' SelLength (get)
+
+Property Let SelLength(ByVal pvValue As Variant)
+ Call _PropertySet("SelLength", pvValue)
+End Property ' SelLength (set)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get SelStart() As Variant
+ SelStart = _PropertyGet("SelStart")
+End Property ' SelStart (get)
+
+Property Let SelStart(ByVal pvValue As Variant)
+ Call _PropertySet("SelStart", pvValue)
+End Property ' SelStart (set)
+
+REM -----------------------------------------------------------------------------------------------------------------------
+Property Get SelText() As Variant
+ SelText = _PropertyGet("SelText")
+End Property ' SelText (get)
+
+Property Let SelText(ByVal pvValue As Variant)
+ Call _PropertySet("SelText", pvValue)
+End Property ' SelText (set)
+
+REM -----------------------------------------------------------------------------------------------------------------------
Property Get SpecialEffect() As Variant
SpecialEffect = _PropertyGet("SpecialEffect")
End Property ' SpecialEffect (get)
@@ -569,21 +601,19 @@ Dim j As Integer, oView As Object
Next i
ocControl._Initialize()
+ ocControl._DocEntry = _DocEntry
+ ocControl._DbEntry = _DbEntry
Set Controls = ocControl
Exit_Function:
Utils._ResetCalledSub("Grid.Controls")
Exit Function
-Trace_Error:
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , 1)
- Set Controls = Nothing
- Goto Exit_Function
Trace_Error_Index:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0, 1)
Set Controls = Nothing
Goto Exit_Function
Trace_NotFound:
- TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, vObject._Name))
+ TraceError(TRACEFATAL, ERRCONTROLNOTFOUND, Utils._CalledSub(), 0, , Array(pvIndex, _Name))
Set Controls = Nothing
Goto Exit_Function
Trace_Error_Context:
@@ -684,11 +714,11 @@ Error_Function:
RemoveItem = False
GoTo Exit_Function
Error_Control:
- TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0)
+ TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.RemoveItem")
RemoveItem = False
Goto Exit_Function
Error_Index:
- TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,2)
+ TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(2, pvIndex))
RemoveItem = False
Goto Exit_Function
End Function ' RemoveItem V0.9.1
@@ -720,7 +750,7 @@ Exit_Function:
Utils._ResetCalledSub("Control.Requery")
Exit Function
Error_Control:
- TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0)
+ TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, "Control.Requery")
Requery = False
Goto Exit_Function
Error_Function:
@@ -981,6 +1011,9 @@ Dim vFullPropertiesList() As Variant
, "RowSource" _
, "RowSourceType" _
, "Selected" _
+ , "SelLength" _
+ , "SelStart" _
+ , "Seltext" _
, "SpecialEffect" _
, "SubType" _
, "TabIndex" _
@@ -995,65 +1028,65 @@ Dim vFullPropertiesList() As Variant
Dim vPropertiesMatrix(25) As Variant
Select Case _ParentType
Case CTLPARENTISFORM, CTLPARENTISSUBFORM
- vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,31,32,36,37,38,39,40,42,43,44,45)
- vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,31,32,33,34,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,9,10,11,12,13,14,15,16,17,27,28,31,37,38,39,40,42,45)
- vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,42,44,45)
- vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,37,38,39,40,41,44,45)
+ vPropertiesMatrix(acCheckBox) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,31,32,39,40,41,42,43,45,46,47,48)
+ vPropertiesMatrix(acComboBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,27,28,31,32,33,34,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,31,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acCurrencyField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acDateField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,40,41,42,43,44,47,48)
vPropertiesMatrix(acFixedLine) = Array()
- vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,31,37,40,42,45)
- vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,31,37,38,39,40,45)
- vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,31,37,40,45)
- vPropertiesMatrix(acHiddenControl) = Array(7,27,28,31,37,40,44,45)
- vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,37,38,39,40,45)
- vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,31,32,37,38,39,40,45)
- vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,31,32,33,34,35,37,38,39,40,42,44,45)
- vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,31,37,38,39,40,45)
- vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,42,44,45)
- vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,41,42,44,45)
+ vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,31,40,43,45,48)
+ vPropertiesMatrix(acFormattedField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acGridControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,27,28,31,40,41,42,43,48)
+ vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,31,40,43,48)
+ vPropertiesMatrix(acHiddenControl) = Array(7,27,28,31,40,43,47,48)
+ vPropertiesMatrix(acImageButton) = Array(0,1,2,6,7,10,27,28,31,40,41,42,43,48)
+ vPropertiesMatrix(acImageControl) = Array(0,1,2,5,6,7,10,25,27,28,31,32,40,41,42,43,48)
+ vPropertiesMatrix(acListBox) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,31,32,33,34,35,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acNavigationBar) = Array(0,2,6,7,10,11,12,13,14,15,16,17,27,28,31,40,41,42,43,48)
+ vPropertiesMatrix(acNumericField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acPatternField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,36,37,38,40,41,42,43,44,45,47,48)
vPropertiesMatrix(acProgressBar) = Array()
- vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,42,44,45)
- vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,31,37,38,39,40,44,45)
- vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,31,37,38,39,40,44,45)
- vPropertiesMatrix(0) = Array(7,18,21,22,27,28,31,37)
- vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,37,38,39,40,41,42,44,45)
+ vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,39,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,31,40,41,42,43,47,48)
+ vPropertiesMatrix(acSpinButton) = Array(0,1,2,6,7,9,10,27,28,31,40,41,42,43,47,48)
+ vPropertiesMatrix(0) = Array(7,18,21,22,27,28,31,40)
+ vPropertiesMatrix(acTextField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,25,27,28,31,32,36,37,38,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acTimeField) = Array(0,1,2,5,6,7,9,10,11,12,13,14,15,16,17,19,25,27,28,31,32,40,41,42,43,44,45,47,48)
Case CTLPARENTISGROUP
' To be duplicated from above !!!
- vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,36,37,38,39,40,42,44,45)
+ vPropertiesMatrix(acRadioButton) = Array(0,4,5,6,7,9,10,11,12,13,14,15,16,17,27,28,29,31,32,39,40,41,42,43,45,47,48)
Case CTLPARENTISGRID
- vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,31,32,36,37,40,42,43,44)
- vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,31,32,33,34,37,40,41,42,44)
- vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,42,44)
- vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,37,40,41,42,44)
- vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,37,40,41,42,44)
- vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,31,32,33,34,35,37,40,42,44)
- vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,42,44)
- vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,41,42,44)
- vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,31,32,37,40,41,42,44)
- vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,37,40,41,42,44)
+ vPropertiesMatrix(acCheckBox) = Array(4,5,6,7,9,10,27,28,31,32,39,40,43,45,46,47)
+ vPropertiesMatrix(acComboBox) = Array(4,5,6,7,9,10,20,23,24,25,27,28,31,32,33,34,40,43,44,45,47)
+ vPropertiesMatrix(acCurrencyField) = Array(4,5,6,7,9,10,25,27,28,31,32,40,43,45,47)
+ vPropertiesMatrix(acDateField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,40,43,44,45,47)
+ vPropertiesMatrix(acFormattedField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,40,43,44,45,47)
+ vPropertiesMatrix(acListBox) = Array(4,5,6,7,9,10,20,23,24,25,26,27,28,31,32,33,34,35,40,43,45,47)
+ vPropertiesMatrix(acNumericField) = Array(4,5,6,7,9,10,25,27,28,31,32,40,43,45,47)
+ vPropertiesMatrix(acPatternField) = Array(4,5,6,7,9,10,25,27,28,31,32,36,37,38,40,43,44,45,47)
+ vPropertiesMatrix(acTextField) = Array(4,5,6,7,9,10,25,27,28,31,32,36,37,38,40,43,44,45,47)
+ vPropertiesMatrix(acTimeField) = Array(4,5,6,7,9,10,19,25,27,28,31,32,40,43,44,45,47)
Case CTLPARENTISDIALOG
- vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,36,37,38,39,40,42,43,44,45)
- vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,30,31,33,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,30,31,37,38,39,40,42,45)
- vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,42,44,45)
- vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,37,38,40,45)
- vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,37,38,39,40,42,45)
- vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,37,38,40,45)
- vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,30,31,37,38,39,40,45)
- vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,30,31,33,35,37,38,39,40,42,44,45)
- vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,42,44,45)
- vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,30,31,37,38,40,44,45)
- vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,30,31,36,37,38,39,40,42,44,45)
- vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,31,37,38,39,40,44,45)
- vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,37,38,39,40,41,42,44,45)
- vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,37,38,39,40,41,42,44,45)
+ vPropertiesMatrix(acCheckBox) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,39,40,41,42,43,45,46,47,48)
+ vPropertiesMatrix(acComboBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,27,28,30,31,33,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acCommandButton) = Array(0,3,4,6,7,8,10,11,12,13,14,15,16,17,27,28,30,31,40,41,42,43,45,48)
+ vPropertiesMatrix(acCurrencyField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acDateField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acFileControl) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acFixedLine) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,40,41,43,48)
+ vPropertiesMatrix(acFixedText) = Array(0,1,2,4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,40,41,42,43,45,48)
+ vPropertiesMatrix(acFormattedField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acGroupBox) = Array(4,6,7,10,11,12,13,14,15,16,17,27,28,30,31,40,41,43,48)
+ vPropertiesMatrix(acImageControl) = Array(0,1,2,6,7,10,27,28,30,31,40,41,42,43,48)
+ vPropertiesMatrix(acListBox) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,20,23,24,25,26,27,28,30,31,33,35,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acNumericField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acPatternField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,36,37,38,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acProgressBar) = Array(0,1,2,6,7,10,27,28,30,31,40,41,43,47,48)
+ vPropertiesMatrix(acRadioButton) = Array(0,4,6,7,10,11,12,13,14,15,16,17,27,28,29,30,31,39,40,41,42,43,45,47,48)
+ vPropertiesMatrix(acScrollBar) = Array(0,1,2,6,7,10,27,28,30,31,40,41,42,43,47,48)
+ vPropertiesMatrix(acTextField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,25,27,28,30,31,36,37,38,40,41,42,43,44,45,47,48)
+ vPropertiesMatrix(acTimeField) = Array(0,1,2,6,7,10,11,12,13,14,15,16,17,19,25,27,28,30,31,40,41,42,43,44,45,47,48)
End Select
Dim vProperties() As Variant, i As Integer, iIndex As Integer
@@ -1097,6 +1130,7 @@ Dim vListboxValue As Variant, vListSource, bSelected() As Boolean, bListboxBound
Dim vGet As Variant, vDate As Variant
Dim ofSubForm As Object
Dim vFormats() As Variant
+Dim vSelection As Variant, sSelectedText As String
If Not hasProperty(psProperty) Then Goto Trace_Error
@@ -1121,7 +1155,7 @@ Dim vFormats() As Variant
If Utils._hasUNOProperty(ControlModel, "DefaultButton") Then _PropertyGet = ControlModel.DefaultButton
Case UCase("DefaultValue")
Select Case _SubType
- Case CTLCHECKBOX, CTLCOMMANDBUTTON, CTLRADIOBUTTON
+ Case CTLCHECKBOX, CTLRADIOBUTTON
If Utils._hasUNOProperty(ControlModel, "DefaultState") Then _PropertyGet = ControlModel.DefaultState
Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD
If Utils._hasUNOProperty(ControlModel, "DefaultText") Then _PropertyGet = ControlModel.DefaultText
@@ -1188,10 +1222,15 @@ Dim vFormats() As Variant
If Utils._hasUNOProperty(ControlModel, "TextColor") Then _PropertyGet = ControlModel.TextColor
Case UCase("Form")
Set ofSubForm = New SubForm ' Start building the SUBFORM object
- Set ofSubForm.DatabaseForm = ControlModel
- ofSubForm._Name = _Name
- ofSubForm._Shortcut = _Shortcut & ".Form"
- ofSubForm.ParentComponent = _FormComponent
+ With ofSubForm
+ Set ._This = ofSubForm
+ Set .DatabaseForm = ControlModel
+ ._Name = _Name
+ ._Shortcut = _Shortcut & ".Form"
+ .ParentComponent = _FormComponent
+ ._DocEntry = _DocEntry
+ ._DbEntry = _DbEntry
+ End With
set _PropertyGet = ofSubForm
Case UCase("Format")
vFormats = _Formats(_Subtype)
@@ -1332,6 +1371,34 @@ Dim vFormats() As Variant
If IsMissing(pvIndex) Then _PropertyGet = bSelected Else _PropertyGet = bSelected(pvIndex)
End If
End If
+ Case UCase("SelLength")
+ If Utils._hasUNOProperty(ControlView, "Selection") Then
+ vSelection = ControlView.getSelection()
+ If vSelection.Max >= vSelection.Min Then
+ _PropertyGet = vSelection.Max - vSelection.Min
+ Else
+ _PropertyGet = 0 ' probably control does not have focus
+ End If
+ Else
+ _PropertyGet = 0
+ End If
+ Case UCase("SelStart")
+ If Utils._hasUNOProperty(ControlView, "Selection") Then
+ vSelection = ControlView.getSelection()
+ If vSelection.Max >= vSelection.Min Then
+ _PropertyGet = vSelection.Min + 1
+ Else
+ _PropertyGet = 1 ' probably control does not have focus
+ End If
+ Else
+ _PropertyGet = 1
+ End If
+ Case UCase("SelText")
+ If Utils._hasUNOProperty(ControlView, "SelectedText") Then
+ _PropertyGet = ControlView.getSelectedText()
+ Else
+ _PropertyGet = ""
+ End If
Case UCase("SpecialEffect")
If Utils._hasUNOProperty(ControlModel, "VisualEffect") Then _PropertyGet = ControlModel.VisualEffect
Case UCase("SubType")
@@ -1381,6 +1448,11 @@ Dim vFormats() As Variant
Select Case _SubType
Case CTLCHECKBOX
If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ControlModel.State
+ Case CTLCOMMANDBUTTON
+ vGet = False
+ If Utils._hasUNOProperty(ControlModel, "Toggle") Then
+ If Utils._hasUNOProperty(ControlModel, "State") Then vGet = ( ControlModel.State = 1 )
+ End If
Case CTLCOMBOBOX, CTLFILECONTROL, CTLPATTERNFIELD, CTLTEXTFIELD
If Utils._hasUNOProperty(ControlModel, "Text") Then vGet = ControlModel.Text
Case CTLCURRENCYFIELD
@@ -1514,6 +1586,7 @@ Dim odbDatabase As Object, vNames() As Variant, bFound As Boolean, sName As Stri
Dim bMultiSelect As Boolean, iCount As Integer, iSelectedItems() As Integer, lListCount As Long, bSelected() As Boolean
Dim vItemList() As Variant, vFormats() As Variant
Dim oStruct As Object, sValue As String
+Dim vSelection As Variant, sText As String, lStart As long
_PropertySet = True
Select Case UCase(_A2B_.CalledSub)
@@ -1749,7 +1822,7 @@ Dim oStruct As Object, sValue As String
Case com.sun.star.form.ListSourceType.QUERY _
, com.sun.star.form.ListSourceType.TABLE _
, com.sun.star.form.ListSourceType.TABLEFIELDS
- Set odbDatabase = Application._CurrentDb()
+ Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
If ControlModel.ListSourceType = com.sun.star.form.ListSourceType.QUERY Then vNames = odbDatabase.Connection.getQueries.GetElementNames _
Else vNames = odbDatabase.Connection.getTables.GetElementNames
bFound = False ' Check existence of table or query and find its correct (case-sensitive) name
@@ -1764,7 +1837,8 @@ Dim oStruct As Object, sValue As String
If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = sName Else ControlModel.ListSource = Array(sName)
ControlModel.refresh()
Case com.sun.star.form.ListSourceType.SQL
- If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = Utils._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(Utils._ReplaceSquareBrackets(pvValue))
+ Set odbDatabase = Application._CurrentDb(_DocEntry, _DbEntry)
+ If _SubType = CTLCOMBOBOX Then ControlModel.ListSource = odbDatabase._ReplaceSquareBrackets(pvValue) Else ControlModel.ListSource = Array(odbDatabase._ReplaceSquareBrackets(pvValue))
ControlModel.refresh()
Case com.sun.star.form.ListSourceType.VALUELIST ' Forbidden for COMBOBOX !
If _SubType = CTLCOMBOBOX Then Goto Trace_Error
@@ -1862,6 +1936,35 @@ Dim oStruct As Object, sValue As String
ControlModel.SelectedItems = Array()
End If
End If
+ Case UCase("SelLength")
+ If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error
+ If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
+ If pvValue < 0 Then Goto Trace_Error_Value
+ vSelection = ControlView.getSelection()
+ vSelection.Max = vSelection.Min + pvValue
+ ControlView.setSelection(vSelection)
+ Case UCase("SelStart")
+ If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error
+ If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
+ If pvValue < 1 Or pvValue > Len(ControlModel.Text) + 1 Then Goto Trace_Error_Value
+ vSelection = ControlView.getSelection()
+ vSelection.Min = pvValue - 1
+ vSelection.Max = pvValue - 1 ' Also reset length to 0
+ ControlView.setSelection(vSelection)
+ Case UCase("SelText")
+ If Not Utils._hasUNOProperty(ControlView, "Selection") Then Goto trace_Error
+ If Not Utils._hasUNOProperty(ControlModel, "Text") Then Goto trace_Error
+ If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value
+ If Len(pvValue) > 0 Then
+ vSelection = ControlView.getSelection()
+ sText = ControlModel.Text
+ lStart = InStr(1, sText, pvValue, 0) ' Case sensitive !
+ If lStart > 0 Then
+ vSelection.Min = lStart - 1
+ vSelection.Max = lStart + Len(pvValue) - 1
+ ControlView.setSelection(vSelection)
+ End If
+ End If
Case UCase("SpecialEffect")
If Not Utils._hasUNOProperty(ControlModel, "VisualEffect") Then Goto Trace_Error
If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value
@@ -1897,6 +2000,11 @@ Dim oStruct As Object, sValue As String
If VarType(pvValue) = vbBoolean Then pvValue = Iif(pvValue, 1, 0)
If pvValue < 0 Or pvValue > 2 Then Goto Trace_Error_Value ' 0 = Not checked 1 = Checked 2 = don't know
ControlModel.State = pvValue
+ Case CTLCOMMANDBUTTON
+ If Not Utils._hasUNOProperty(ControlModel, "State") Then Goto Trace_Error
+ If Not Utils._hasUNOProperty(ControlModel, "Toggle") Then Goto Trace_Error
+ If Not Utils._CheckArgument(pvValue, iArgNr, vbBoolean, , False) Then Goto Trace_Error_Value
+ If pvValue Then ControlModel.State = 1 Else ControlModel.State = 0
Case CTLCOMBOBOX
If Not Utils._hasUNOProperty(ControlModel, "Text") Or Not Utils._hasUNOProperty(ControlModel, "StringItemList") _
Then Goto Trace_Error
@@ -2043,7 +2151,7 @@ Error_Function:
TraceError(TRACEABORT, Err, "Control._PropertySet", Erl)
_PropertySet = False
GoTo Exit_Function
-End Function ' _PropertySet V1.0.0
+End Function ' _PropertySet V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS PROPERTY SETs ---
@@ -2155,6 +2263,18 @@ Property Set Selected(ByVal pvValue As Variant) ' , ByVal Optional pvIndex
Call _PropertySet("Selected", pvValue)
End Property ' Selected (set)
+Property Set SelLength(ByVal pvValue As Variant)
+ Call _PropertySet("SelLength", pvValue)
+End Property ' SelLength (set)
+
+Property Set SelStart(ByVal pvValue As Variant)
+ Call _PropertySet("SelStart", pvValue)
+End Property ' SelStart (set)
+
+Property Set SelText(ByVal pvValue As Variant)
+ Call _PropertySet("SelText", pvValue)
+End Property ' SelText (set)
+
Property Set SpecialEffect(ByVal pvValue As Variant)
Call _PropertySet("SpecialEffect", pvValue)
End Property ' SpecialEffect (set)
diff --git a/wizards/source/access2base/DataDef.xba b/wizards/source/access2base/DataDef.xba
index 2de30f8..4236548 100644
--- a/wizards/source/access2base/DataDef.xba
+++ b/wizards/source/access2base/DataDef.xba
@@ -16,8 +16,13 @@ REM ----------------------------------------------------------------------------
Private _Type As String ' Must be TABLEDEF or QUERYDEF
Private _Name As String
+Private _ParentDatabase As Object
+Private _ReadOnly As Boolean
Private Table As Object ' com.sun.star.sdb.dbaccess.ODBTable
Private Query As Object ' com.sun.star.sdb.dbaccess.OQuery
+Private TableDescriptor As Object ' com.sun.star.sdb.dbaccess.ODBTable
+Private TableFieldsCount As Integer
+Private TableKeysCount As Integer
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
@@ -25,8 +30,13 @@ REM ----------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = ""
_Name = ""
+ Set _ParentDatabase = Nothing
+ _ReadOnly = False
Set Table = Nothing
Set Query = Nothing
+ Set TableDescriptor = Nothing
+ TableFieldsCount = 0
+ TableKeysCount = 0
End Sub ' Constructor
REM -----------------------------------------------------------------------------------------------------------------------
@@ -55,14 +65,123 @@ Property Let SQL(ByVal pvValue As Variant)
End Property ' SQL (set)
REM -----------------------------------------------------------------------------------------------------------------------
-Property Get pType() As Integer
+Public Function pType() As Integer
pType = _PropertyGet("Type")
-End Property ' Type (get)
+End Function ' Type (get)
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
+Public Function CreateField(ByVal Optional pvFieldName As Variant _
+ , ByVal optional pvType As Variant _
+ , ByVal optional pvSize As Variant _
+ , ByVal optional pvAttributes As variant _
+ ) As Object
+'Return a Field object
+Const cstThisSub = "TableDef.CreateField"
+ Utils._SetCalledSub(cstThisSub)
+
+ If _ErrorHandler() Then On Local Error Goto Error_Function
+
+Dim oTable As Object, oNewField As Object, oKeys As Object, oPrimaryKey As Object, oColumn As Object
+Const cstMaxKeyLength = 30
+
+ CreateField = Nothing
+ If _ParentDatabase._DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
+ If IsMissing(pvFieldName) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvFieldName, 1, vbString) Then Goto Exit_Function
+ If pvFieldName = "" Then Call _TraceArguments()
+ If IsMissing(pvType) Then Call _TraceArguments()
+ If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric( _
+ dbInteger, dbLong, dbBigInt, dbFloat, vbSingle, dbDouble _
+ , dbNumeric, dbDecimal, dbText, dbChar, dbMemo _
+ , dbDate, dbTime, dbTimeStamp _
+ , dbBinary, dbVarBinary, dbLongBinary, dbBoolean _
+ )) Then Goto Exit_Function
+ If IsMissing(pvSize) Then pvSize = 0
+ If pvSize < 0 Then pvSize = 0
+ If Not Utils._CheckArgument(pvSize, 1, Utils._AddNumeric()) Then Goto Exit_Function
+ If IsMissing(pvAttributes) Then pvAttributes = 0
+ If Not Utils._CheckArgument(pvAttributes, 1, Utils._AddNumeric(), Array(0, dbAutoIncrField)) Then Goto Exit_Function
+
+ If _Type <> OBJTABLEDEF Then Goto Error_NotApplicable
+ If IsNull(Table) And IsNull(TableDescriptor) Then Goto Error_NotApplicable
+
+ If _ReadOnly Then Goto Error_NoUpdate
+
+ Set oNewField = New Field
+ With oNewField
+ ._Name = pvFieldName
+ ._ParentName = _Name
+ ._ParentType = OBJTABLEDEF
+ If IsNull(Table) Then Set oTable = TableDescriptor Else Set oTable = Table
+ Set .Column = oTable.Columns.createDataDescriptor()
+ End With
+ With oNewField.Column
+ .Name = pvFieldName
+ Select Case pvType
+ Case dbInteger : .Type = com.sun.star.sdbc.DataType.TINYINT
+ Case dbLong : .Type = com.sun.star.sdbc.DataType.INTEGER
+ Case dbBigInt : .Type = com.sun.star.sdbc.DataType.BIGINT
+ Case dbFloat : .Type = com.sun.star.sdbc.DataType.FLOAT
+ Case dbSingle : .Type = com.sun.star.sdbc.DataType.REAL
+ Case dbDouble : .Type = com.sun.star.sdbc.DataType.DOUBLE
+ Case dbNumeric, dbCurrency : .Type = com.sun.star.sdbc.DataType.NUMERIC
+ Case dbDecimal : .Type = com.sun.star.sdbc.DataType.DECIMAL
+ Case dbText : .Type = com.sun.star.sdbc.DataType.CHAR
+ Case dbChar : .Type = com.sun.star.sdbc.DataType.VARCHAR
+ Case dbMemo : .Type = com.sun.star.sdbc.DataType.LONGVARCHAR
+ Case dbDate : .Type = com.sun.star.sdbc.DataType.DATE
+ Case dbTime : .Type = com.sun.star.sdbc.DataType.TIME
+ Case dbTimeStamp : .Type = com.sun.star.sdbc.DataType.TIMESTAMP
+ Case dbBinary : .Type = com.sun.star.sdbc.DataType.BINARY
+ Case dbVarBinary : .Type = com.sun.star.sdbc.DataType.VARBINARY
+ Case dbLongBinary : .Type = com.sun.star.sdbc.DataType.LONGVARBINARY
+ Case dbBoolean : .Type = com.sun.star.sdbc.DataType.BOOLEAN
+ End Select
+ .Precision = Int(pvSize)
+ If pvType = dbNumeric Or pvType = dbDecimal Or pvType = dbCurrency Then .Scale = Int(pvSize * 10) - Int(pvSize) * 10
+ .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE
+ If Not IsNull(TableDescriptor) Then TableFieldsCount = TableFieldsCount + 1
+ If pvAttributes = dbAutoIncrField Then
+ If Not IsNull(Table) Then Goto Error_Sequence ' Do not accept adding an AutoValue field when table exists
+ Set oKeys = oTable.Keys
+ Set oPrimaryKey = oKeys.createDataDescriptor()
+ Set oColumn = oPrimaryKey.Columns.createDataDescriptor()
+ oColumn.Name = pvFieldName
+ oColumn.IsAutoIncrement = True
+ oPrimaryKey.Columns.appendByDescriptor(oColumn)
+ oPrimaryKey.Name = Left("PK_" & Join(Split(oNewField._ParentName, " "), "_") & "_" & Join(Split(pvFieldName, " "), "_"), cstMaxKeyLength)
+ oKeys.appendByDescriptor(oPrimaryKey)
+ .IsAutoIncrement = True
+ .IsNullable = com.sun.star.sdbc.ColumnValue.NO_NULLS
+ oColumn.dispose()
+ Else
+ .IsAutoIncrement = False
+ End If
+ End With
+ oTable.Columns.appendByDescriptor(oNewfield.Column)
+
+ Set CreateField = oNewField
+
+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_Sequence:
+ TraceError(TRACEFATAL, ERRFIELDCREATION, Utils._CalledSub(), 0, 1, pvFieldName)
+ Goto Exit_Function
+Error_NoUpdate:
+ TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
+ Goto Exit_Function
+End Function ' CreateField V1.1.0
+
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Execute(ByVal Optional pvOptions As Variant) As Boolean
'Execute a stored query. The query must be an ACTION query.
@@ -81,19 +200,18 @@ Const cstNull = -1
End If
'Check action query
-Dim oDatabase As Object, oStatement As Object, vResult As Variant
+Dim oStatement As Object, vResult As Variant
Dim iType As Integer, sSql As String
iType = pType
If ( (iType And DBQAction) = 0 ) And ( (iType And DBQDDL) = 0 ) Then Goto Trace_Action
'Execute action query
- Set oDatabase = Application._CurrentDb()
- Set oStatement = oDatabase.Connection.createStatement()
+ Set oStatement = _ParentDatabase.Connection.createStatement()
sSql = Query.Command
If pvOptions = dbSQLPassThrough Then oStatement.EscapeProcessing = False _
- Else oStatement.EscapeProcessing = True
+ Else oStatement.EscapeProcessing = Query.EscapeProcessing
On Local Error Goto SQL_Error
- vResult = oStatement.executeUpdate(Utils._ReplaceSquareBrackets(sSql))
+ vResult = oStatement.executeUpdate(_ParentDatabase._ReplaceSquareBrackets(sSql))
On Local Error Goto Error_Function
Execute = True
@@ -113,7 +231,7 @@ SQL_Error:
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
-End Function ' Execute
+End Function ' Execute V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Fields(ByVal Optional pvIndex As variant) As Object
@@ -139,6 +257,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object
oObject._CollType = COLLFIELDS
oObject._ParentType = _Type
oObject._ParentName = _Name
+ Set oObject._ParentDatabase = _ParentDatabase
oObject._Count = UBound(sObjects) + 1
Goto Exit_Function
Case VarType(pvIndex) = vbString
@@ -162,6 +281,7 @@ Dim i As Integer, bFound As Boolean, oFields As Object
Set oObject.Column = oFields.getByName(sObjectName)
oObject._ParentName = _Name
oObject._ParentType = _Type
+ Set oObject._ParentDatabase = _ParentDatabase
Exit_Function:
Set Fields = oObject
@@ -172,7 +292,7 @@ Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Trace_NotFound:
- TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array("Field", pvIndex))
+ TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex))
Goto Exit_Function
Trace_IndexError:
TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
@@ -207,14 +327,14 @@ End Function ' hasProperty
REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenRecordset(ByVal Optional pvType As Variant, ByVal Optional pvOptions As Variant, ByVal Optional pvLockEdit As Variant) As Object
-'Return a Recordset object based on current tabledef object
+'Return a Recordset object based on current table- or querydef object
Dim cstThisSub As String
cstThisSub = Utils._PCase(_Type) & ".OpenRecordset"
Utils._SetCalledSub(cstThisSub)
Const cstNull = -1
-Dim lCommandType As Long, sCommand As String, oObject As Object
-Dim odbDatabase As Object
+Dim lCommandType As Long, sCommand As String, oObject As Object,bPassThrough As Boolean
+
Set oObject = Nothing
If IsMissing(pvType) Then
pvType = cstNull
@@ -239,6 +359,7 @@ Dim odbDatabase As Object
Case OBJQUERYDEF
lCommandType = com.sun.star.sdb.CommandType.QUERY
sCommand = _Name
+ If pvOptions = dbSQLPassThrough Then bPassThrough = True Else bPassThrough = Not Query.EscapeProcessing
End Select
Set oObject = New Recordset
@@ -248,12 +369,12 @@ Dim odbDatabase As Object
._ParentName = _Name
._ParentType = _Type
._ForwardOnly = ( pvType = dbOpenForwardOnly )
- ._PassThrough = ( pvOptions = dbSQLPassThrough )
- ._ReadOnly = ( pvLockEdit = dbReadOnly )
+ ._PassThrough = bPassThrough
+ ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly )
+ Set ._ParentDatabase = _ParentDatabase
Call ._Initialize()
End With
- Set odbDatabase = Application._CurrentDb()
- With odbDatabase
+ With _ParentDatabase
.RecordsetMax = .RecordsetMax + 1
oObject._Name = Format(.RecordsetMax, "0000000")
.RecordsetsColl.Add(oObject, UCase(oObject._Name))
@@ -270,7 +391,7 @@ Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
Set oObject = Nothing
GoTo Exit_Function
-End Function ' OpenRecordset
+End Function ' OpenRecordset V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
@@ -290,6 +411,7 @@ Dim cstThisSub As String
vProperty = PropertiesGet._Properties(sObject, _Name, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If
+ Set vProperty._ParentDatabase = _ParentDatabase
Exit_Function:
Set Properties = vProperty
@@ -325,6 +447,7 @@ Dim cstThisSub As String
Utils._SetCalledSub(cstThisSub & ".get" & psProperty)
Dim vEMPTY As Variant, sSql As String, sVerb As String, iType As Integer
_PropertyGet = vEMPTY
+ If Not hasProperty(psProperty) Then Goto Trace_Error
Select Case UCase(psProperty)
Case UCase("Name")
@@ -361,7 +484,7 @@ Exit_Function:
Utils._ResetCalledSub(cstThisSub & ".get" & psProperty)
Exit Function
Trace_Error:
- TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
+ TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = vEMPTY
Goto Exit_Function
Error_Function:
@@ -390,6 +513,8 @@ Dim iArgNr As Integer
End Select
If Not hasProperty(psProperty) Then Goto Trace_Error
+
+ If _ReadOnly Then Goto Error_NoUpdate
Select Case UCase(psProperty)
Case UCase("SQL")
@@ -410,6 +535,9 @@ Trace_Error_Value:
TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty))
_PropertySet = False
Goto Exit_Function
+Error_NoUpdate:
+ TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
+ Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub & "._PropertySet", Erl)
_PropertySet = False
diff --git a/wizards/source/access2base/Database.xba b/wizards/source/access2base/Database.xba
index b09b7dd..cbfec70 100644
--- a/wizards/source/access2base/Database.xba
+++ b/wizards/source/access2base/Database.xba
@@ -15,17 +15,16 @@ REM --- CLASS ROOT FIELDS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private _Type As String ' Must be DATABASE
-Private _Standalone As Boolean
+Private _This As Object ' Workaround for absence of This builtin function
+Private _DbConnect As Integer ' DBCONNECTxxx constants
Private Title As String
-Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument
-Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper
+Private Document As Object ' com.sun.star.comp.dba.ODatabaseDocument or SwXTextDocument or ScModelObj
+Private Connection As Object ' com.sun.star.sdbc.drivers.OConnectionWrapper or com.sun.star.sdbc.XConnection
Private URL As String
+Private _ReadOnly As Boolean
Private MetaData As Object ' interface XDatabaseMetaData
Private Form As Object ' com.sun.star.form.XForm
-Private FormName As String ' name of standalone form
-Private FindRecord As Object
-Private StatusBar As Object
-Private Dialogs As Object ' Collection
+Private FormName As String
Private RecordsetMax As Integer
Private RecordsetsColl As Object ' Collection of active recordsets
@@ -34,17 +33,16 @@ REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJDATABASE
- _Standalone = False
+ Set _This = Nothing
+ _DbConnect = 0
Title = ""
Set Document = Nothing
Set Connection = Nothing
URL = ""
+ _ReadOnly = False
Set MetaData = Nothing
Set Form = Nothing
FormName = ""
- Set FindRecord = Nothing
- Set StatusBar = Nothing
- Set Dialogs = New Collection
RecordsetMax = 0
Set RecordsetsColl = New Collection
End Sub ' Constructor
@@ -65,6 +63,31 @@ REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
REM -----------------------------------------------------------------------------------------------------------------------
+Public Function mClose() As Variant
+' Close the form
+
+If _ErrorHandler() Then On Local Error Goto Error_Function
+Const cstThisSub = "Database.Close"
+ Utils._SetCalledSub(cstThisSub)
+ mClose = False
+ If _DbConnect <> DBCONNECTANY Then Goto Error_NotApplicable
+
+ Connection.close()
+ Connection.dispose()
+ mClose = True
+
+Exit_Function:
+ Utils._ResetCalledSub(cstThisSub)
+ Exit Function
+Error_NotApplicable:
+ TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
+ Goto Exit_Function
+Error_Function:
... etc. - the rest is truncated
More information about the Libreoffice-commits
mailing list