Current File : //usr/lib/libreoffice/share/basic/Access2Base/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 <> COLLECTION (is a reserved name for ... collections)
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private _Type As String ' Must be COLLECTION
Private _This As Object ' Workaround for absence of This builtin function
Private _CollType As String
Private _Parent As Object
Private _Count As Long
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
_Type = OBJCOLLECTION
Set _This = Nothing
_CollType = ""
Set _Parent = Nothing
_Count = 0
End Sub ' Constructor
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
On Local Error Resume Next
Call Class_Initialize()
End Sub ' Destructor
REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
Call Class_Terminate()
End Sub ' Explicit destructor
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES ---
REM -----------------------------------------------------------------------------------------------------------------------
Property Get Count() As Long
Count = _PropertyGet("Count")
End Property ' Count (get)
REM -----------------------------------------------------------------------------------------------------------------------
Function Item(ByVal Optional pvItem As Variant) As Variant
'Return property value.
'pvItem either numeric index or property name
Const cstThisSub = "Collection.getItem"
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub(cstThisSub)
If IsMissing(pvItem) Then Goto Exit_Function ' To allow object watching in Basic IDE, do not generate error
Select Case _CollType
Case COLLCOMMANDBARCONTROLS ' 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 COLLALLMODULES
Set Item = Application.AllModules(pvItem)
Case COLLCOMMANDBARS
Set Item = Application.CommandBars(pvItem)
Case COLLCOMMANDBARCONTROLS
If IsNull(_Parent) Then GoTo Error_Parent
Set Item = _Parent.CommandBarControls(pvItem)
Case COLLCONTROLS
If IsNull(_Parent) Then GoTo Error_Parent
Set Item = _Parent.Controls(pvItem)
Case COLLFORMS
Set Item = Application.Forms(pvItem)
Case COLLFIELDS
If IsNull(_Parent) Then GoTo Error_Parent
Set Item = _Parent.Fields(pvItem)
Case COLLPROPERTIES
If IsNull(_Parent) Then GoTo Error_Parent
Select Case _Parent._Type
Case OBJCONTROL, OBJSUBFORM, OBJDATABASE, OBJDIALOG, OBJFIELD _
, OBJFORM, OBJQUERYDEF, OBJRECORDSET, OBJTABLEDEF
Set Item = _Parent.Properties(pvItem)
Case OBJCOLLECTION, OBJEVENT, OBJOPTIONGROUP, OBJPROPERTY
' NOT SUPPORTED
End Select
Case COLLQUERYDEFS
Set Item = _Parent.QueryDefs(pvItem)
Case COLLRECORDSETS
Set Item = _Parent.Recordsets(pvItem)
Case COLLTABLEDEFS
Set Item = _Parent.TableDefs(pvItem)
Case COLLTEMPVARS
Set Item = Application.TempVars(pvItem)
Case Else
End Select
Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
Set Item = Nothing
GoTo Exit_Function
Error_Parent:
TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, True, Array(_GetLabel("OBJECT"), _GetLabel("PARENT")))
Set Item = Nothing
GoTo Exit_Function
End Function ' Item V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
ObjectType = _PropertyGet("ObjectType")
End Property ' ObjectType (get)
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
' a Collection object if pvIndex absent
' a Property object otherwise
Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
vPropertiesList = _PropertiesList()
sObject = Utils._PCase(_Type)
If IsMissing(pvIndex) Then
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
Else
vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
End If
Exit_Function:
Set Properties = vProperty
Exit Function
End Function ' Properties
REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS ---
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Add(Optional pvNew As Variant, Optional pvValue As Variant) As Boolean
' Append a new TableDef or TempVar object to the TableDefs/TempVars collections
Const cstThisSub = "Collection.Add"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function
Dim odbDatabase As Object, oConnection As Object, oTables As Object, 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 <> 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 = "" Then Goto Error_Name
If IsMissing(pvValue) Then Call _TraceArguments()
If _A2B_.hasItem(COLLTEMPVARS, pvNew) Then Goto Error_Name
Set oTempVar = New TempVar
oTempVar._This = oTempVar
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 ' Add 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 _A2B_.CurrentDocIndex() <> 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
_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 ' Delete V1.1.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name
Utils._SetCalledSub("Collection.getProperty")
If IsMissing(pvProperty) Then Call _TraceArguments()
getProperty = _PropertyGet(pvProperty)
Utils._ResetCalledSub("Collection.getProperty")
End Function ' getProperty
REM -----------------------------------------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)
If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
Exit Function
End Function ' hasProperty
REM -----------------------------------------------------------------------------------------------------------------------
Public Function Remove(ByVal Optional pvName As Variant) As Boolean
' Remove a TempVar from the TempVars collection
Const cstThisSub = "Collection.Remove"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function
Dim oColl As Object, vName As Variant
Remove = False
If IsMissing(pvName) Then pvName = ""
If Not Utils._CheckArgument(pvName, 1, vbString) Then Goto Exit_Function
If pvName = "" Then Call _TraceArguments()
Select Case _CollType
Case COLLTEMPVARS
If Not _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 ' Remove V1.2.0
REM -----------------------------------------------------------------------------------------------------------------------
Public Function RemoveAll() As Boolean
' Remove the whole TempVars collection
Const cstThisSub = "Collection.Remove"
Utils._SetCalledSub(cstThisSub)
If _ErrorHandler() Then On Local Error Goto Error_Function
Select Case _CollType
Case COLLTEMPVARS
Set _A2B_.TempVars = New Collection
_Count = 0
Case Else
Goto Error_NotApplicable
End Select
Exit_Function:
Utils._ResetCalledSub(cstThisSub)
Exit Function
Error_Function:
TraceError(TRACEABORT, Err, cstThisSub, Erl)
GoTo Exit_Function
Error_NotApplicable:
TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
Goto Exit_Function
End Function ' RemoveAll V1.2.0
REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant
_PropertiesList = Array("Count", "Item", "ObjectType")
End Function ' _PropertiesList
REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name
If _ErrorHandler() Then On Local Error Goto Error_Function
Utils._SetCalledSub("Collection.get" & psProperty)
_PropertyGet = Nothing
Select Case UCase(psProperty)
Case UCase("Count")
_PropertyGet = _Count
Case UCase("Item")
Case UCase("ObjectType")
_PropertyGet = _Type
Case Else
Goto Trace_Error
End Select
Exit_Function:
Utils._ResetCalledSub("Collection.get" & psProperty)
Exit Function
Trace_Error:
TraceError(TRACEWARNING, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty)
_PropertyGet = Nothing
Goto Exit_Function
Error_Function:
TraceError(TRACEABORT, Err, "Collection._PropertyGet", Erl)
_PropertyGet = Nothing
GoTo Exit_Function
End Function ' _PropertyGet
</script:module>
Mini Shell