EVOLUTION-MANAGER

Edit File: Collect.xba

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Collect" script:language="StarBasic">REM =======================================================================================================================
REM ===					The Access2Base library is a part of the LibreOffice project.									===
REM ===					Full documentation is available on http://www.access2base.com									===
REM =======================================================================================================================

Option Compatible
Option ClassModule

Option Explicit

REM MODULE NAME &lt;&gt; COLLECTION (seems a reserved name ?)

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS 								        														---
REM -----------------------------------------------------------------------------------------------------------------------

Private _Type			As String		&apos;	Must be COLLECTION
Private _CollType		As String
Private _ParentType		As String
Private _ParentName		As String		&apos;	Name or shortcut
Private _ParentDatabase	As Object
Private _Count			As Long

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS						        														---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
	_Type = OBJCOLLECTION
	_CollType = &quot;&quot;
	_ParentType = &quot;&quot;
	_ParentName = &quot;&quot;
	Set _ParentDatabase = Nothing
	_Count = 0
End Sub		&apos;	Constructor

REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
	On Local Error Resume Next
	Call Class_Initialize()
End Sub		&apos;	Destructor

REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
	Call Class_Terminate()
End Sub		&apos;	Explicit destructor

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES					        														---
REM -----------------------------------------------------------------------------------------------------------------------

Property Get Count() As Long
	Count = _PropertyGet(&quot;Count&quot;)
End Property		&apos;	Count (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get Item(ByVal Optional pvItem As Variant) As Variant
&apos;Return property value.
&apos;pvItem either numeric index or property name

Const cstThisSub = &quot;Collection.getItem&quot;
	Utils._SetCalledSub(cstThisSub)
	If IsMissing(pvItem) Then Goto Exit_Function	&apos;	To allow object watching in Basic IDE, do not generate error
	Select Case _CollType
		Case COLLCOMMANDBARCONTROLS					&apos;	Have no name
			If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric()) Then Goto Exit_Function
		Case Else
			If Not Utils._CheckArgument(pvItem, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
	End Select

Dim vNames() As Variant, oProperty As Object

Set Item = Nothing
	Select Case _CollType
		Case COLLALLDIALOGS
			Set Item = Application.AllDialogs(pvItem)
		Case COLLALLFORMS
			Set Item = Application.AllForms(pvItem)
		Case COLLCOMMANDBARS
			Set Item = Application.CommandBars(pvItem)
		Case COLLCOMMANDBARCONTROLS
			Set Item = Application.CommandBars(_ParentName).CommandBarControls(pvItem)
		Case COLLCONTROLS
			Select Case _ParentType
				Case OBJCONTROL, OBJSUBFORM
					Set Item = getObject(_ParentName).Controls(pvItem)
				Case OBJDIALOG
					Set Item = Application.AllDialogs(_ParentName).Controls(pvItem)
				Case OBJFORM
					Set Item = Application.Forms(_ParentName).Controls(pvItem)
				Case OBJOPTIONGROUP
					&apos; NOT SUPPORTED
			End Select
		Case COLLFORMS
			Set Item = Application.Forms(pvItem)
		Case COLLFIELDS
			Select Case _ParentType
				Case OBJQUERYDEF
					Set Item = _ParentDatabase.QueryDefs(_ParentName).Fields(pvItem)
				Case OBJRECORDSET
					Set Item = _ParentDatabase.Recordsets(_ParentName).Fields(pvItem)
				Case OBJTABLEDEF
					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 = _ParentDatabase.Properties(pvItem)
				Case OBJDIALOG
					Set Item = Application.AllDialogs(_ParentName).Properties(pvItem)
				Case OBJFIELD
					vNames() = Split(_ParentName, &quot;/&quot;)
					Select Case vNames(0)
						Case OBJQUERYDEF
							Set Item = _ParentDatabase.QueryDefs(vNames(1)).Fields(vNames(2)).Properties(pvItem)
						Case OBJRECORDSET
							Set Item = _ParentDatabase.Recordsets(vNames(1)).Fields(vNames(2)).Properties(pvItem)
						Case OBJTABLEDEF
							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 = _ParentDatabase.QueryDefs(_ParentName).Properties(pvItem)
				Case OBJRECORDSET
					Set Item = _ParentDatabase.Recordsets(_ParentName).Properties(pvItem)
				Case OBJTABLEDEF
					Set Item = _ParentDatabase.TableDefs(_ParentName).Properties(pvItem)
				Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY
					&apos; NOT SUPPORTED
			End Select
		Case COLLQUERYDEFS
			Set Item = _ParentDatabase.QueryDefs(pvItem)
		Case COLLRECORDSETS
			Set Item = _ParentDatabase.Recordsets(pvItem)
		Case COLLTABLEDEFS
			Set Item = _ParentDatabase.TableDefs(pvItem)
		Case COLLTEMPVARS
			Set Item = Application.TempVars(pvItem)
		Case Else
	End Select

Exit_Function:
	Utils._ResetCalledSub(cstThisSub)
	Exit Property
Error_Function:
	TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
	Set Item = Nothing
	GoTo Exit_Function
End Property		&apos;	V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
	ObjectType = _PropertyGet(&quot;ObjectType&quot;)
End Property		&apos;	ObjectType (get)

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
&apos;	Return
&apos;		a Collection object if pvIndex absent
&apos;		a Property object otherwise

Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
	vPropertiesList = _PropertiesList()
	sObject = Utils._PCase(_Type)
	If IsMissing(pvIndex) Then
		vProperty = PropertiesGet._Properties(sObject, _ParentName, vPropertiesList)
	Else
		vProperty = PropertiesGet._Properties(sObject, _ParentName, vPropertiesList, pvIndex)
		vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
	End If
	
Exit_Function:
	Set Properties = vProperty
	Exit Function
End Function	&apos;	Properties

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS	 								        														---
REM -----------------------------------------------------------------------------------------------------------------------

Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean
&apos;	Append a new TableDef or TempVar object to the TableDefs/TempVars collections

Const cstThisSub = &quot;Collection.Add&quot;
	Utils._SetCalledSub(cstThisSub)
	If _ErrorHandler() Then On Local Error Goto Error_Function
	
Dim odbDatabase As Object, oConnection As Object, oTables As Object, oTable As Object
Dim vObject As Variant, oTempVar As Object
	Add = False
	If IsMissing(pvNew) Then Call _TraceArguments()

Select Case _CollType
		Case COLLTABLEDEFS
			If Not Utils._CheckArgument(pvNew, 1, vbObject) Then Goto Exit_Function
			Set vObject = pvNew
			With vObject
				Set odbDatabase = ._ParentDatabase
				If odbDatabase._DbConnect &lt;&gt; 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)
				.CatalogName = .Table.CatalogName
				.SchemaName = .Table.SchemaName
				.TableName = .Table.Name
				.TableDescriptor.dispose()
				Set .TableDescriptor = Nothing
				.TableFieldsCount = 0
				.TableKeysCount = 0
			End With
		Case COLLTEMPVARS
			If Not Utils._CheckArgument(pvNew, 1, vbString) Then Goto Exit_Function
			If pvNew = &quot;&quot; Then Goto Error_Name
			If IsMissing(pvValue) Then Call _TraceArguments()
			If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name
			Set oTempVar = New TempVar
			oTempVar._Name = pvNew
			oTempVar._Value = pvValue
			_A2B_.TempVars.Add(oTempVar, UCase(pvNew))
		Case Else
			Goto Error_NotApplicable
	End Select

_Count = _Count + 1
	Add = True

Exit_Function:
	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, vObject._Name)
	Goto Exit_Function
Error_Name:
	TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvNew))
	AddItem = False
	Goto Exit_Function
End Function		&apos;	Add	V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Delete(ByVal Optional pvName As Variant) As Boolean
&apos;	Delete a TableDef or QueryDef object in the TableDefs/QueryDefs collections

Const cstThisSub = &quot;Collection.Delete&quot;
	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 = &quot;&quot;
	If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
	If pvName = &quot;&quot; Then Call _TraceArguments()

Select Case _CollType
		Case COLLTABLEDEFS, COLLQUERYDEFS
			If _A2B_.CurrentDocIndex() &lt;&gt; 0 Then Goto Error_NotApplicable 
			Set odbDatabase = Application._CurrentDb()
			If odbDatabase._DbConnect &lt;&gt; 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

_Count = _Count - 1
	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		&apos;	Delete	V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
&apos;	Return property value of psProperty property name

Utils._SetCalledSub(&quot;Collection.getProperty&quot;)
	If IsMissing(pvProperty) Then Call _TraceArguments()
	getProperty = _PropertyGet(pvProperty)
	Utils._ResetCalledSub(&quot;Collection.getProperty&quot;)
	
End Function		&apos;	getProperty

REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
&apos;	Return True if object has a valid property called pvProperty (case-insensitive comparison !)

If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
	Exit Function
	
End Function	&apos;	hasProperty

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Remove(ByVal Optional pvName As Variant) As Boolean
&apos;	Remove a TempVar from the TempVars collection

Const cstThisSub = &quot;Collection.Remove&quot;
	Utils._SetCalledSub(cstThisSub)
	If _ErrorHandler() Then On Local Error Goto Error_Function
	
Dim oColl As Object, vName As Variant
	Remove = False
	If IsMissing(pvName) Then pvName = &quot;&quot;
	If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
	If pvName = &quot;&quot; Then Call _TraceArguments()

Select Case _CollType
		Case COLLTEMPVARS
			If Not _A2B_.hasItem(COLLTEMPVARS, pvName) Then Goto Error_Name
			_A2B_.TempVars.Remove(UCase(pvName))
		Case Else
			Goto Error_NotApplicable
	End Select

_Count = _Count - 1
	Remove = True

Exit_Function:
	Utils._ResetCalledSub(cstThisSub)
	Exit Function
Error_Function:
	TraceError(TRACEABORT, Err, cstThisSub, Erl)
	GoTo Exit_Function
Error_NotApplicable:
	TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
	Goto Exit_Function
Error_Name:
	TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), False, ,Array(1, pvName))
	AddItem = False
	Goto Exit_Function
End Function		&apos;	Remove	V1.2.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function RemoveAll() As Boolean
&apos;	Remove the whole TempVars collection

Const cstThisSub = &quot;Collection.Remove&quot;
	Utils._SetCalledSub(cstThisSub)
	If _ErrorHandler() Then On Local Error Goto Error_Function

Select Case _CollType
		Case COLLTEMPVARS
			Set _A2B_.TempVars = New Collection
			_Count = 0
		Case Else
			Goto Error_NotApplicable
	End Select

REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS 								        														---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
	 _PropertiesList = Array(&quot;Count&quot;, &quot;Item&quot;, &quot;ObjectType&quot;)
End Function	&apos;	_PropertiesList

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
&apos;	Return property value of the psProperty property name

If _ErrorHandler() Then On Local Error Goto Error_Function
	Utils._SetCalledSub(&quot;Collection.get&quot; &amp; psProperty)
	_PropertyGet = Nothing
	
	Select Case UCase(psProperty)
		Case UCase(&quot;Count&quot;)
			_PropertyGet = _Count
		Case UCase(&quot;Item&quot;)
		Case UCase(&quot;ObjectType&quot;)
			_PropertyGet = _Type
		Case Else
			Goto Trace_Error
	End Select
	
Exit_Function:
	Utils._ResetCalledSub(&quot;Collection.get&quot; &amp; psProperty)
	Exit Function
Trace_Error:
	TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
	_PropertyGet = Nothing
	Goto Exit_Function
Error_Function:
	TraceError(TRACEABORT, Err, &quot;Collection._PropertyGet&quot;, Erl)
	_PropertyGet = Nothing
	GoTo Exit_Function
End Function		&apos;	_PropertyGet
</script:module>