Quelle  Collect.xba   Sprache: unbekannt

<?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>