Quelle  Database.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="Database" script:language="StarBasic">
REM =======================================================================================================================
REM ===     The Access2Base library is a part of the LibreOffice project.         ===
REM ===     Full documentation is available on http://www.access2base.com         ===
REM =======================================================================================================================

Option Compatible
Option ClassModule

Option Explicit

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

Private _Type     As String    ' Must be DATABASE
Private _This     As Object    ' Workaround for absence of This builtin function
Private _Parent     As Object
Private _DbConnect    As Integer    ' DBCONNECTxxx constants
Private Title     As String
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 Location    As String    ' Different from URL for registered databases
Private _ReadOnly    As Boolean
Private MetaData    As Object    ' interface XDatabaseMetaData
Private _RDBMS     As Integer    ' DBMS constants
Private _ColumnTypes()   As Variant    ' Part of Metadata.GetTypeInfo()
Private _ColumnTypeNames()  As Variant
Private _ColumnPrecisions()  As Variant
Private _ColumnTypesReference() As Variant
Private _ColumnTypesAlias()  As Variant    ' To what should a field whose origin is another DBMS be converted ? See DataTypes By RDBMS.ods
Private _BinaryStream   As Boolean    ' False = binary fields must NOT be streamed f.i. via ReadAllBytes or WriteAllBytes
Private Form     As Object    ' com.sun.star.form.XForm
Private FormName    As String
Private RecordsetMax   As Long     ' To make unique names in Collection below (See bug # 121342)
Private RecordsetsColl   As Object    ' Collection of active recordsets

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS                            ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
 _Type = OBJDATABASE
 Set _This = Nothing
 Set _Parent = Nothing
 _DbConnect = 0
 Title = ""
 Set Document = Nothing
 Set Connection = Nothing
 URL = ""
 _ReadOnly = False
 Set MetaData = Nothing
 _RDBMS = DBMS_UNKNOWN
 _ColumnTypes = Array()
 _ColumnTypeNames = Array()
 _ColumnPrecisions = Array()
 _ColumnTypesReference = Array()
 _ColumnTypesAlias() = Array()
 _BinaryStream = False
 Set Form = Nothing
 FormName = ""
 RecordsetMax = 0
 Set RecordsetsColl = New Collection
End Sub  ' Constructor

REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
 On Local Error Resume Next
 Call CloseAllRecordsets()
 If _DbConnect <> DBCONNECTANY Then
  If Not IsNull(Connection) Then
   Connection.close()
   Connection.dispose()
   Set Connection = Nothing
  End If
 Else
  mClose()
 End If
 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 Connect() As String
 Connect = _PropertyGet("Connect")
End Property  ' Connect (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
 Name = _PropertyGet("Name")
End Property  ' Name (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
 ObjectType = _PropertyGet("ObjectType")
End Property  ' ObjectType (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnCreate() As String
 OnCreate = _PropertyGet("OnCreate")
End Property  ' OnCreate (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnFocus() As String
 OnFocus = _PropertyGet("OnFocus")
End Property  ' OnFocus (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnLoad() As String
 OnLoad = _PropertyGet("OnLoad")
End Property  ' OnLoad (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnLoadFinished() As String
 OnLoadFinished = _PropertyGet("OnLoadFinished")
End Property  ' OnLoadFinished (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnModifyChanged() As String
 OnModifyChanged = _PropertyGet("OnModifyChanged")
End Property  ' OnModifyChanged (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnNew() As String
 OnNew = _PropertyGet("OnNew")
End Property  ' OnNew (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnPrepareUnload() As String
 OnPrepareUnload = _PropertyGet("OnPrepareUnload")
End Property  ' OnPrepareUnload (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnPrepareViewClosing() As String
 OnPrepareViewClosing = _PropertyGet("OnPrepareViewClosing")
End Property  ' OnPrepareViewClosing (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSave() As String
 OnSave = _PropertyGet("OnSave")
End Property  ' OnSave (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveAs() As String
 OnSaveAs = _PropertyGet("OnSaveAs")
End Property  ' OnSaveAs (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveAsDone() As String
 OnSaveAsDone = _PropertyGet("OnSaveAsDone")
End Property  ' OnSaveAsDone (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveAsFailed() As String
 OnSaveAsFailed = _PropertyGet("OnSaveAsFailed")
End Property  ' OnSaveAsFailed (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveDone() As String
 OnSaveDone = _PropertyGet("OnSaveDone")
End Property  ' OnSaveDone (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSaveFailed() As String
 OnSaveFailed = _PropertyGet("OnSaveFailed")
End Property  ' OnSaveFailed (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSubComponentClosed() As String
 OnSubComponentClosed = _PropertyGet("OnSubComponentClosed")
End Property  ' OnSubComponentClosed (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnSubComponentOpened() As String
 OnSubComponentOpened = _PropertyGet("OnSubComponentOpened")
End Property  ' OnSubComponentOpened (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnTitleChanged() As String
 OnTitleChanged = _PropertyGet("OnTitleChanged")
End Property  ' OnTitleChanged (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnfocus() As String
 OnUnfocus = _PropertyGet("OnUnfocus")
End Property  ' OnUnfocus (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnUnload() As String
 OnUnload = _PropertyGet("OnUnload")
End Property  ' OnUnload (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnViewClosed() As String
 OnViewClosed = _PropertyGet("OnViewClosed")
End Property  ' OnViewClosed (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get OnViewCreated() As String
 OnViewCreated = _PropertyGet("OnViewCreated")
End Property  ' OnViewCreated (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get Version() As String
 Version = _PropertyGet("Version")
End Property  ' Version (get)

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

REM -----------------------------------------------------------------------------------------------------------------------
Public Function mClose() As Variant
' Close the database

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

 With Connection
  If Utils._hasUNOMethod(Connection, "flush") Then .flush
  .close()
  .dispose()
 End With
 Set Connection = Nothing
 mClose = True

Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_NotApplicable:
 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 Goto Exit_Function
Error_Function:
 TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl)
 GoTo Exit_Function
End Function  ' (m)Close

REM -----------------------------------------------------------------------------------------------------------------------
Public Sub CloseAllRecordsets()
' Clean all recordsets for housekeeping

Dim sRecordsets() As String, i As Integer, oRecordset As Object
 On Local Error Goto Exit_Sub

 If IsNull(RecordsetsColl) Then Exit Sub
 If RecordsetsColl.Count < 1 Then Exit Sub
 For i = 1 To RecordsetsColl.Count
  Set oRecordset = RecordsetsColl.Item(i)
  oRecordset.mClose(False)  ' Do not remove entry in collection
 Next i
 Set RecordsetsColl = New Collection
 RecordsetMax = 0

Exit_Sub:
 Exit Sub
End Sub    ' CloseAllRecordsets V0.9.5

REM -----------------------------------------------------------------------------------------------------------------------
Public Function CreateQueryDef(ByVal Optional pvQueryName As Variant _
        , ByVal Optional pvSql As Variant _
        , ByVal Optional pvOption As Variant _
        ) As Object
'Return a (new) QueryDef object based on SQL statement
Const cstThisSub = "Database.CreateQueryDef"
 Utils._SetCalledSub(cstThisSub)

Const cstNull = -1
Dim oQuery As Object, oQueries As Object, i As Integer, sQueryName As String

 If _ErrorHandler() Then On Local Error Goto Error_Function

 Set CreateQueryDef = Nothing
 If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
 If IsMissing(pvQueryName) Then Call _TraceArguments()
 If IsMissing(pvSql) Then Call _TraceArguments()
 If IsMissing(pvOption) Then pvOption = cstNull

 If Not Utils._CheckArgument(pvQueryName, 1, vbString) Then Goto Exit_Function
 If pvQueryName = "" Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvSql, 2, vbString) Then Goto Exit_Function
 If pvSql = "" Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvOption, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function

 If _ReadOnly Then Goto Error_NoUpdate

 Set oQuery = CreateUnoService("com.sun.star.sdb.QueryDefinition")
 oQuery.rename(pvQueryName)
 oQuery.Command = _ReplaceSquareBrackets(pvSql)
 oQuery.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )

 Set oQueries = Document.DataSource.getQueryDefinitions()
 With oQueries
  For i = 0 To .getCount() - 1
   sQueryName = .getByIndex(i).Name
   If UCase(sQueryName) = UCase(pvQueryName) Then
    TraceError(TRACEWARNING, ERRQUERYDEFDELETED, Utils._CalledSub(), 0, False, sQueryName)
    .removeByName(sQueryName)
    Exit For
   End If
  Next i
  .insertByName(pvQueryName, oQuery)
 End With
 Set CreateQueryDef = QueryDefs(pvQueryName)

Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_NotApplicable:
 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 Goto Exit_Function
Error_NoUpdate:
 TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
 Goto Exit_Function
Error_Function:
 TraceError(TRACEABORT, Err, cstThisSub, Erl)
 GoTo Exit_Function
End Function ' CreateQueryDef V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function CreateTableDef(ByVal Optional pvTableName As Variant) As Object
'Return a (new/empty) TableDef object
Const cstThisSub = "Database.CreateTableDef"
 Utils._SetCalledSub(cstThisSub)

Dim oTable As Object, oTables As Object, sTables() As String
Dim i As Integer, sTableName As String, oNewTable As Object
Dim vNameComponents() As Variant, iNames As Integer

 If _ErrorHandler() Then On Local Error Goto Error_Function

 Set CreateTableDef = Nothing
 If _DbConnect <> DBCONNECTBASE Then Goto Error_NotApplicable
 If IsMissing(pvTableName) Then Call _TraceArguments()

 If Not Utils._CheckArgument(pvTableName, 1, vbString) Then Goto Exit_Function
 If pvTableName = "" Then Call _TraceArguments()

 If _ReadOnly Then Goto Error_NoUpdate

 Set oTables = Connection.getTables
 With oTables
  sTables = .ElementNames()
  ' Check existence of object and find its exact (case-sensitive) name
  For i = 0 To UBound(sTables)
   If UCase(pvTableName) = UCase(sTables(i)) Then
    sTableName = sTables(i)
    TraceError(TRACEWARNING, ERRTABLEDEFDELETED, Utils._CalledSub(), 0, False, sTableName)
    .dropByName(sTableName)
    Exit For
   End If
  Next i
  Set oNewTable = New DataDef
  Set oNewTable._This = oNewTable
  oNewTable._Type = OBJTABLEDEF
  oNewTable._Name = pvTableName
  vNameComponents = Split(pvTableName, ".")
  iNames = UBound(vNameComponents)
  If iNames >= 2 Then oNewtable.CatalogName = vNameComponents(iNames - 2) Else oNewTable.CatalogName = ""
  If iNames >= 1 Then oNewtable.SchemaName = vNameComponents(iNames - 1) Else oNewTable.SchemaName = ""
  oNewtable.TableName = vNameComponents(iNames)
  Set oNewTable._ParentDatabase = _This
  Set oNewTable.TableDescriptor = .createDataDescriptor()
  oNewTable.TableDescriptor.CatalogName = oNewTable.CatalogName
  oNewTable.TableDescriptor.SchemaName = oNewTable.SchemaName
  oNewTable.TableDescriptor.Name = oNewTable.TableName
  oNewTable.TableDescriptor.Type = "TABLE"
 End With

 Set CreateTabledef = oNewTable

Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_NotApplicable:
 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 Goto Exit_Function
Error_NoUpdate:
 TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0)
 Goto Exit_Function
Error_Function:
 TraceError(TRACEABORT, Err, cstThisSub, Erl)
 GoTo Exit_Function
End Function ' CreateTableDef V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DAvg( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return average of scope
Const cstThisSub = "Database.DAvg"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DAvg = _DFunction("AVG", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DAvg

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DCount( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return # of occurrences of scope
Const cstThisSub = "Database.DCount"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DCount = _DFunction("COUNT", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DCount

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DLookup( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     , ByVal Optional pvOrderClause As Variant _
     ) As Variant

' Return a value within a table
    'Arguments: psExpr:   an SQL expression
    '   psDomain:  a table- or queryname
    '   pvCriteria:  an optional WHERE clause
    '   pcOrderClause: an optional order clause incl. "DESC" if relevant
    'Return:    Value of the psExpr if found, else Null.
    'Author:    inspired from Allen Browne. http://allenbrowne.com/ser-42.html
    'Examples:
    '           1. To find the last value, include DESC in the OrderClause, e.g.:
    '               DLookup("[Surname] & [FirstName]", "tblClient", , "ClientID DESC")
    '           2. To find the lowest non-null value of a field, use the Criteria, e.g.:
    '               DLookup("ClientID", "tblClient", "Surname Is Not Null" , "Surname")

Const cstThisSub = "Database.DLookup"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DLookup = _DFunction("", psExpr, psDomain _
     , Iif(IsMissing(pvCriteria), "", pvCriteria) _
     , Iif(IsMissing(pvOrderClause), "", pvOrderClause) _
     )
 Utils._ResetCalledSub(cstThisSub)
End Function ' DLookup

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DMax( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return maximum of scope
Const cstThisSub = "Database.DMax"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DMax = _DFunction("MAX", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DMax

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DMin( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return minimum of scope
Const cstThisSub = "Database.DMin"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DMin = _DFunction("MIN", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DMin

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DStDev( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return standard deviation of scope
Const cstThisSub = "Database.DStDev"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DStDev = _DFunction("STDDEV_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
 Utils._ResetCalledSub(cstThisSub)
End Function ' DStDev

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DStDevP( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return standard deviation of scope
Const cstThisSub = "Database.DStDevP"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DStDevP = _DFunction("STDDEV_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "") ' STDDEV not STDEV !
 Utils._ResetCalledSub(cstThisSub)
End Function ' DStDevP

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DSum( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return sum of scope
Const cstThisSub = "Database.DSum"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DSum = _DFunction("SUM", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DSum

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DVar( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return variance of scope
Const cstThisSub = "Database.DVar"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DVar = _DFunction("VAR_SAMP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DVar

REM -----------------------------------------------------------------------------------------------------------------------
Public Function DVarP( _
     ByVal Optional psExpr As String _
     , ByVal Optional psDomain As String _
     , ByVal Optional pvCriteria As Variant _
     ) As Variant
' Return variance of scope
Const cstThisSub = "Database.DVarP"
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(psExpr) Or IsMissing(psDomain) Then Call _TraceArguments()
 DVarP = _DFunction("VAR_POP", psExpr, psDomain, Iif(IsMissing(pvCriteria), "", pvCriteria), "")
 Utils._ResetCalledSub(cstThisSub)
End Function ' DVarP

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

 Utils._SetCalledSub("Database.getProperty")
 If IsMissing(pvProperty) Then Call _TraceArguments()
 getProperty = _PropertyGet(pvProperty)
 Utils._ResetCalledSub("Database.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 OpenRecordset(ByVal Optional pvSource As Variant _
        , ByVal Optional pvType As Variant _
        , ByVal Optional pvOptions As Variant _
        , ByVal Optional pvLockEdit As Variant _
        ) As Object
'Return a Recordset object based on Source (= SQL, table or query name)

Const cstThisSub = "Database.OpenRecordset"
 Utils._SetCalledSub(cstThisSub)
Const cstNull = -1

Dim lCommandType As Long, sCommand As String, oObject As Object
Dim sSource As String, i As Integer, iCount As Integer
Dim sObjects() As String, bFound As Boolean, oTables As Object, oQueries As Object
Dim iType As Integer, iOptions As Integer, iLockEdit As Integer

 If _ErrorHandler() Then On Local Error Goto Error_Function
 Set oObject = Nothing
 If IsMissing(pvSource) Then Call _TraceArguments()
 If pvSource = "" Then Call _TraceArguments()
 If VarType(pvType) = vbError Then
  iType = cstNull
 ElseIf IsMissing(pvType) Then
  iType = cstNull
 Else
  If Not Utils._CheckArgument(pvType, 2, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function
  iType = pvType
 End If
 If VarType(pvOptions) = vbError Then
  iOptions = cstNull
 ElseIf IsMissing(pvOptions) Then
  iOptions = cstNull
 Else
  If Not Utils._CheckArgument(pvOptions, 3, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
  iOptions = pvOptions
 End If
 If VarType(pvLockEdit) = vbError Then
  iLockEdit = cstNull
 ElseIf IsMissing(pvLockEdit) Then
  iLockEdit = cstNull
 Else
  If Not Utils._CheckArgument(pvLockEdit, 4, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function
  iLockEdit = pvLockEdit
 End If

 sSource = Split(UCase(Trim(pvSource)), " ")(0)
 Select Case True
  Case sSource = "SELECT"
   lCommandType = com.sun.star.sdb.CommandType.COMMAND
   sCommand = _ReplaceSquareBrackets(pvSource)
  Case Else
   sSource = UCase(Trim(pvSource))
   REM Explore tables
   Set oTables = Connection.getTables
   sObjects = oTables.ElementNames()
   bFound = False
   For i = 0 To UBound(sObjects)
    If sSource = UCase(sObjects(i)) Then
     sCommand = sObjects(i)
     bFound = True
     Exit For
    End If
   Next i
   If bFound Then
    lCommandType = com.sun.star.sdb.CommandType.TABLE
   Else
    REM Explore queries
    Set oQueries = Connection.getQueries
    sObjects = oQueries.ElementNames()
    For i = 0 To UBound(sObjects)
     If sSource = UCase(sObjects(i)) Then
      sCommand = sObjects(i)
      bFound = True
      Exit For
     End If
    Next i
    If Not bFound Then Goto Trace_NotFound
    lCommandType = com.sun.star.sdb.CommandType.QUERY
   End If
 End Select

 Set oObject = New Recordset
 With oObject
  ._CommandType = lCommandType
  ._Command = sCommand
  ._ParentName = Title
  ._ParentType = _Type
  ._ForwardOnly = ( iType = dbOpenForwardOnly )
  ._PassThrough = ( iOptions = dbSQLPassThrough )
  ._ReadOnly = ( (iLockEdit = dbReadOnly) Or _ReadOnly )
  Set ._This = oObject
  Set ._ParentDatabase = _This
  Call ._Initialize()
  RecordsetMax = RecordsetMax + 1
  ._Name = Format(RecordsetMax, "0000000")
  RecordsetsColl.Add(oObject, UCase(._Name))
 End With

 If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst()  ' Do nothing if resultset empty

Exit_Function:
 Set OpenRecordset = oObject
 Set oObject = Nothing
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, cstThisSub, Erl)
 GoTo Exit_Function
Trace_NotFound:
 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE") & "/" & _GetLabel("QUERY"), pvSource))
 Goto Exit_Function
End Function ' OpenRecordset V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function OpenSQL(Optional ByVal pvSQL As Variant _
      , Optional ByVal pvOption As Variant _
      ) As Boolean
' Return True if the execution of the SQL statement was successful
' SQL must contain a SELECT query
' pvOption can force pass through mode

 If _ErrorHandler() Then On Local Error Goto Error_Function

Const cstThisSub = "Database.OpenSQL"
 Utils._SetCalledSub(cstThisSub)

 OpenSQL = False
 If IsMissing(pvSQL) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
Const cstNull = -1
 If IsMissing(pvOption) Then
  pvOption = cstNull
 Else
  If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(dbSQLPassThrough, cstNull)) Then Goto Exit_Function
 End If
 If _DbConnect <> DBCONNECTBASE And _DbConnect <> DBCONNECTFORM Then Goto Error_NotApplicable

Dim oURL As New com.sun.star.util.URL, oDispatch As Object
Dim vArgs(8) as New com.sun.star.beans.PropertyValue

 oURL.Complete = ".component:DB/DataSourceBrowser"
 oDispatch = StarDesktop.queryDispatch(oURL, "_Blank", 8)

 vArgs(0).Name = "ActiveConnection"  : vArgs(0).Value = Connection
 vArgs(1).Name = "CommandType"   : vArgs(1).Value = com.sun.star.sdb.CommandType.COMMAND
 vArgs(2).Name = "Command"    : vArgs(2).Value = _ReplaceSquareBrackets(pvSQL)
 vArgs(3).Name = "ShowMenu"    : vArgs(3).Value = True
 vArgs(4).Name = "ShowTreeView"   : vArgs(4).Value = False
 vArgs(5).Name = "ShowTreeViewButton" : vArgs(5).Value = False
 vArgs(6).Name = "Filter"    : vArgs(6).Value = ""
 vArgs(7).Name = "ApplyFilter"   : vArgs(7).Value = False
 vArgs(8).Name = "EscapeProcessing"  : vArgs(8).Value = CBool(Not ( pvOption = dbSQLPassThrough ))

 oDispatch.dispatch(oURL, vArgs)
 OpenSQL = True

Exit_Function:
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, "OpenSQL", Erl)
 GoTo Exit_Function
SQL_Error:
 TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
 Goto Exit_Function
Error_NotApplicable:
 TraceError(TRACEFATAL, ERRMETHOD, Utils._CalledSub(), 0, 1, cstThisSub)
 Goto Exit_Function
End Function  ' OpenSQL  V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function OutputTo(ByVal pvObjectType As Variant _
       , ByVal Optional pvObjectName As Variant _
       , ByVal Optional pvOutputFormat As Variant _
       , ByVal Optional pvOutputFile As Variant _
       , ByVal Optional pvAutoStart As Variant _
       , ByVal Optional pvTemplateFile As Variant _
       , ByVal Optional pvEncoding As Variant _
       , ByVal Optional pvQuality As Variant _
       , ByRef Optional pvHeaders As Variant _
       , ByRef Optional pvData As Variant _
       ) As Boolean
'Supported: acFormatHTML, acFormatODS, acFormatXLS, acFormatXLSX, acFormatTXT  for tables and queries
'pvHeaders and pvData (unpublished) when pvObjectType = acOutputArray

 If _ErrorHandler() Then On Local Error Goto Error_Function
Const cstThisSub = "Database.OutputTo"
 Utils._SetCalledSub(cstThisSub)

 OutputTo = False

 If Not Utils._CheckArgument(pvObjectType, 1, Utils._AddNumeric(), Array(acOutputTable, acOutputQuery, acOutputArray)) Then Goto Exit_Function
 If IsMissing(pvObjectName) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvObjectName, 2, vbString) Then Goto Exit_Function
 If IsMissing(pvOutputFormat) Then pvOutputFormat = ""
 If Not Utils._CheckArgument(pvOutputFormat, 3, vbString) Then Goto Exit_Function
 If pvOutputFormat <> "" Then
  If Not Utils._CheckArgument(UCase(pvOutputFormat), 3, vbString, Array( _
       UCase(acFormatHTML), "HTML" _
       , UCase(acFormatODS), "ODS" _
       , UCase(acFormatXLS), "XLS" _
       , UCase(acFormatXLSX), "XLSX" _
       , UCase(acFormatTXT), "TXT", "CSV" _
       , "")) _
    Then Goto Exit_Function    ' A 2nd time to allow case unsensitivity
 End If
 If IsMissing(pvOutputFile) Then pvOutputFile = ""
 If Not Utils._CheckArgument(pvOutputFile, 4, vbString) Then Goto Exit_Function
 If IsMissing(pvAutoStart) Then pvAutoStart = False
 If Not Utils._CheckArgument(pvAutoStart, 5, vbBoolean) Then Goto Exit_Function
 If IsMissing(pvTemplateFile) Then pvTemplateFile = ""
 If Not Utils._CheckArgument(pvTemplateFile, 6, vbString) Then Goto Exit_Function
 If IsMissing(pvEncoding) Then pvEncoding = 0
 If Not Utils._CheckArgument(pvEncoding, 7, _AddNumeric()) Then Goto Exit_Function
 If IsMissing(pvQuality) Then pvQuality = acExportQualityPrint
 If Not Utils._CheckArgument(pvQuality, 7, _AddNumeric(), Array(acExportQualityPrint, acExportQualityScreen)) Then Goto Exit_Function
 If pvObjectType = acOutputArray Then
  If IsMissing(pvHeaders) Or IsMissing(pvData) Then Call _TraceArguments()
  pvOutputFormat = "HTML"
 End If

Dim sOutputFile As String, oTable As Object
Dim sOutputFormat As String, iTemplate As Integer, iOutputFile As Integer, bOutput As Boolean, sSuffix As String

 If pvObjectType = acOutputArray Then
  Set oTable = Nothing
 Else
  'Find applicable table or query
  If pvObjectType = acOutputTable Then Set oTable = TableDefs(pvObjectName, True) Else Set oTable = Querydefs(pvObjectName, True)
  If IsNull(oTable) Then Goto Error_NotFound
 End If

 'Determine format and parameters
 If pvOutputFormat = "" Then
  sOutputFormat = _PromptFormat(Array("HTML", "ODS", "XLS", "XLSX", "TXT"))   ' Prompt user for format
  If sOutputFormat = "" Then Goto Exit_Function
 Else
  sOutputFormat = UCase(pvOutputFormat)
 End If

 'Determine output file
 If pvOutputFile = "" Then   ' Prompt file picker to user
  Select Case sOutputFormat
   Case UCase(acFormatHTML), "HTML"   :  sSuffix = "html"
   Case UCase(acFormatODS), "ODS"    :  sSuffix = "ods"
   Case UCase(acFormatXLS), "XLS"    :  sSuffix = "xls"
   Case UCase(acFormatXLSX), "XLSX"    : sSuffix = "xlsx"
   Case UCase(acFormatTXT), "TXT", "CSV"  :  sSuffix = "txt"
  End Select
  sOutputFile = _PromptFilePicker(sSuffix)
  If sOutputFile = "" Then Goto Exit_Function
 Else
  sOutputFile = pvOutputFile
 End If
 sOutputFile = ConvertToURL(sOutputFile)

 'Create file
 Select Case sOutputFormat
  Case UCase(acFormatHTML), "HTML"
   If pvObjectType = acOutputArray Then
    bOutput = _OutputToHTML(Nothing, pvObjectName, sOutputFile, pvTemplateFile, pvHeaders, pvData)
   Else
    bOutput = _OutputToHTML(oTable, pvObjectName, sOutputFile, pvTemplateFile)
   End If
  Case UCase(acFormatODS), "ODS"
   bOutput = _OutputToCalc(oTable, sOutputFile, acFormatODS)
  Case UCase(acFormatXLS), "XLS"
   bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLS)
  Case UCase(acFormatXLS), "XLSX"
   bOutput = _OutputToCalc(oTable, sOutputFile, acFormatXLSX)
  Case UCase(acFormatTXT), "TXT", "CSV"
   bOutput = _OutputToCalc(oTable, sOutputFile, acFormatTXT, pvEncoding)
 End Select

 'Launch application, if requested
 If bOutput Then
  If pvAutoStart Then Call _ShellExecute(sOutputFile)
 Else
  GoTo Error_File
 End If

 OutputTo = True

Exit_Function:
 If Not IsNull(oTable) Then
  oTable.Dispose()
  Set oTable = Nothing
 End If
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_NotFound:
 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("OBJECT"), pvObjectName))
 Goto Exit_Function
Error_Function:
 TraceError(TRACEABORT, Err, cstThisSub, Erl)
 GoTo Exit_Function
Error_File:
 TraceError(TRACEFATAL, ERRFILENOTCREATED, Utils._CalledSub(), 0, , sOutputFile)
 GoTo Exit_Function
End Function  ' OutputTo  V1.4.0

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

 Utils._SetCalledSub("Database.Properties")
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
 Set vProperty._ParentDatabase = _This

Exit_Function:
 Set Properties = vProperty
 Utils._ResetCalledSub("Database.Properties")
 Exit Function
End Function ' Properties

REM -----------------------------------------------------------------------------------------------------------------------
Public Function QueryDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
' Collect all Queries in the database
' pbCheck unpublished

 If _ErrorHandler() Then On Local Error Goto Error_Function
 Utils._SetCalledSub("Database.QueryDefs")
 If IsMissing(pbCheck) Then pbCheck = False

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oQueries As Object
 Set oObject = Nothing
 If Not IsMissing(pvIndex) Then
  If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
 End If

 Set oQueries = Connection.getQueries
 sObjects = oQueries.ElementNames()
 Select Case True
  Case IsMissing(pvIndex)
   Set oObject = New Collect
   Set oObject._This = oObject
   oObject._CollType = COLLQUERYDEFS
   Set oObject._Parent = _This
   oObject._Count = UBound(sObjects) + 1
   Goto Exit_Function
  Case VarType(pvIndex) = vbString
   bFound = False
  ' Check existence of object and find its exact (case-sensitive) name
   For i = 0 To UBound(sObjects)
    If UCase(pvIndex) = UCase(sObjects(i)) Then
     sObjectName = sObjects(i)
     bFound = True
     Exit For
    End If
   Next i
   If Not bFound Then Goto Trace_NotFound
  Case Else  ' pvIndex is numeric
   If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
   sObjectName = sObjects(pvIndex)
 End Select

 Set oObject = New DataDef
 Set oObject._This = oObject
 oObject._Type = OBJQUERYDEF
 oObject._Name = sObjectName
 Set oObject._ParentDatabase = _This
 oObject._readOnly = _ReadOnly
 Set oObject.Query = oQueries.getByName(sObjectName)

Exit_Function:
 Set QueryDefs = oObject
 Set oObject = Nothing
 Utils._ResetCalledSub("Database.QueryDefs")
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, "Database.QueryDefs", Erl)
 GoTo Exit_Function
Trace_NotFound:
 If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("QUERY"), pvIndex))
 Goto Exit_Function
Trace_IndexError:
 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
 Goto Exit_Function
End Function  ' QueryDefs V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Recordsets(ByVal Optional pvIndex As Variant) As Object
' Collect all active recordsets

 If _ErrorHandler() Then On Local Error Goto Error_Function
 Utils._SetCalledSub("Database.Recordsets")

 Set Recordsets = Nothing
 If Not IsMissing(pvIndex) Then
  If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
 End If

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oTables As Object

 Select Case True
  Case IsMissing(pvIndex)
   Set oObject = New Collect
   Set oObject._This = oObject
   oObject._CollType = COLLRECORDSETS
   Set oObject._Parent = _This
   oObject._Count = RecordsetsColl.Count
  Case VarType(pvIndex) = vbString
   bFound = _hasRecordset(pvIndex)
   If Not bFound Then Goto Trace_NotFound
   Set oObject = RecordsetsColl.Item(pvIndex)
  Case Else  ' pvIndex is numeric
   If pvIndex < 0 Or pvIndex >= RecordsetsColl.Count Then Goto Trace_IndexError
   Set oObject = RecordsetsColl.Item(pvIndex + 1)  ' Collection members are numbered 1 ... Count
 End Select

Exit_Function:
 Set Recordsets = oObject
 Set oObject = Nothing
 Utils._ResetCalledSub("Database.Recordsets")
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, "Database.Recordsets", Erl)
 GoTo Exit_Function
Trace_NotFound:
 TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("RECORDSET"), pvIndex))
 Goto Exit_Function
Trace_IndexError:
 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
 Goto Exit_Function
End Function  ' Recordsets V0.9.5

REM -----------------------------------------------------------------------------------------------------------------------
Public Function RunSQL(Optional ByVal pvSQL As Variant _
      , Optional ByVal pvOption As Variant _
      ) As Boolean
' Return True if the execution of the SQL statement was successful
' SQL must contain an ACTION query

 If _ErrorHandler() Then On Local Error Goto Error_Function

Const cstThisSub = "Database.RunSQL"
 Utils._SetCalledSub(cstThisSub)

 RunSQL = False
 If IsMissing(pvSQL) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvSQL, 1, vbString) Then Goto Exit_Function
Const cstNull = -1
 If IsMissing(pvOption) Then
  pvOption = cstNull
 Else
  If Not Utils._CheckArgument(pvOption, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function
 End If

Dim oStatement As Object, vResult As Variant
 Set oStatement = Connection.createStatement()
 oStatement.EscapeProcessing = Not ( pvOption = dbSQLPassThrough )
 On Local Error Goto SQL_Error
 vResult = oStatement.execute(_ReplaceSquareBrackets(pvSQL))
 On Local Error Goto Error_Function
 RunSQL = True

Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, cstThisSub, Erl)
 GoTo Exit_Function
SQL_Error:
 TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , pvSQL)
 Goto Exit_Function
End Function  ' RunSQL  V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function TableDefs(ByVal Optional pvIndex As Variant, ByVal Optional pbCheck As Boolean) As Object
' Collect all tables in the database
' pbCheck unpublished

Const cstThisSub = "Database.TableDefs"
 If _ErrorHandler() Then On Local Error Goto Error_Function
 Utils._SetCalledSub(cstThisSub)
 If IsMissing(pbCheck) Then pbCheck = False

Dim sObjects() As String, sObjectName As String, oObject As Object
Dim i As Integer, bFound As Boolean, oTables As Object
 Set oObject = Nothing
 If Not IsMissing(pvIndex) Then
  If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function
 End If

 Set oTables = Connection.getTables
 sObjects = oTables.ElementNames()
 Select Case True
  Case IsMissing(pvIndex)
   Set oObject = New Collect
   Set oObject._This = oObject
   oObject._CollType = COLLTABLEDEFS
   Set oObject._Parent = _This
   oObject._Count = UBound(sObjects) + 1
   Goto Exit_Function
  Case VarType(pvIndex) = vbString
   bFound = False
  ' Check existence of object and find its exact (case-sensitive) name
   For i = 0 To UBound(sObjects)
    If UCase(pvIndex) = UCase(sObjects(i)) Then
     sObjectName = sObjects(i)
     bFound = True
     Exit For
    End If
   Next i
   If Not bFound Then Goto Trace_NotFound
  Case Else  ' pvIndex is numeric
   If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError
   sObjectName = sObjects(pvIndex)
 End Select

 Set oObject = New DataDef
 With oObject
  ._This = oObject
  ._Type = OBJTABLEDEF
  ._Name = sObjectName
  Set ._ParentDatabase = _This
  ._ReadOnly = _ReadOnly
  Set .Table = oTables.getByName(sObjectName)
  .CatalogName = .Table.CatalogName
  .SchemaName = .Table.SchemaName
  .TableName = .Table.Name
 End With

Exit_Function:
 Set TableDefs = oObject
 Set oObject = Nothing
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, cstThisSub, Erl)
 GoTo Exit_Function
Trace_NotFound:
 If Not pbCheck Then TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("TABLE"), pvIndex))
 Goto Exit_Function
Trace_IndexError:
 TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0)
 Goto Exit_Function
End Function  ' TableDefs V1.1.0

REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS                               ---
REM -----------------------------------------------------------------------------------------------------------------------

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

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
Dim sTempField As String  'Random temporary field in SQL expression

Dim sTarget as String, sWhere As String, sOrderBy As String, sLimit As String
Dim sProductName As String

    vResult = Null

 Randomize 2^14-1
 sTempField = "[TEMP" & Right("00000" & Int(100000 * Rnd), 5) & "]"
 If pvCriteria <> "" Then sWhere = " WHERE " & pvCriteria Else sWhere = ""
 If pvOrderClause <> "" Then sOrderBy = " ORDER BY " & pvOrderClause Else sOrderBy = ""
 sLimit = ""

 sProductName = UCase(MetaData.getDatabaseProductName())

 Select Case sProductName
  Case "MYSQL", "SQLITE"
   If psFunction = "" Then
    sTarget = psExpr
    sLimit = " LIMIT 1"
   Else
    sTarget = UCase(psFunction) & "(" & psExpr & ")"
   End If
   sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain &  sWhere & sOrderBy & sLimit
  Case "FIREBIRD (ENGINE12)"
   If psFunction = "" Then sTarget = "FIRST 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
   sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
  Case Else  ' Standard syntax - Includes HSQLDB
   If psFunction = "" Then sTarget = "TOP 1 " & psExpr Else sTarget = UCase(psFunction) & "(" & psExpr & ")"
   sSql = "SELECT " & sTarget & " AS " & sTempField & " FROM " & psDomain & sWhere & sOrderBy
 End Select

    'Lookup the value.
    Set oStatement = Connection.createStatement()
 With oStatement
  .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY
  .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY
  .EscapeProcessing = False
     sSql = _ReplaceSquareBrackets(sSql)  'Substitute [] by quote string
  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, True)  ' Force return of binary field
     End If
    End With

Exit_Function:
    'Assign the returned value.
    _DFunction = vResult
    Set oResult = Nothing
    Set oStatement = Nothing
    Exit Function
Error_Function:
    TraceError(TRACEFATAL, ERRDFUNCTION, _A2B_.CalledSub, 0, , sSQL)
    Goto Exit_Function
End Function  ' DFunction  V1.5.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FilterOptionsDefault(ByVal plEncoding As Long) As String
' Return the default FilterOptions string for table/query export to csv

Dim sFieldSeparator as string
Const cstComma = ","
Const cstTextDelimitor = """"

 If _DecimalPoint() = "," Then sFieldSeparator = ";" Else sFieldSeparator = cstComma
 _FilteroptionsDefault = Trim(Str(Asc(sFieldSeparator))) _
        & cstComma & Trim(Str(Asc(cstTextDelimitor))) _
        & cstComma & Trim(Str(plEncoding)) _
        & cstComma & "1"

End Function  ' _FilterOptionsDefault V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Public Function _hasRecordset(ByVal psName As String) As Boolean
' Return True if psName if in the collection of Recordsets

Dim oRecordset As Object
 If _ErrorHandler() Then On Local Error Goto Error_Function
 Set oRecordset = RecordsetsColl.Item(psName)
 _hasRecordset = True

Exit_Function:
 Exit Function
Error_Function:  ' Item by key aborted
 _hasRecordset = False
 GoTo Exit_Function
End Function ' _hasRecordset V0.9.5

REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _LoadMetadata()
' Load essentially getTypeInfo() results from Metadata

Dim sProduct As String
Dim iInfo As Integer, oTypeInfo As Object, sName As String, lType As Integer

Const cstMaxInfo = 40
 ReDim _ColumnTypes(0 To cstMaxInfo)
 ReDim _ColumnTypeNames(0 To cstMaxInfo)
 ReDim _ColumnPrecisions(0 To cstMaxInfo)
Const cstHSQLDB1 = "HSQL Database Engine 1."
Const cstHSQLDB2 = "HSQL Database Engine 2."
Const cstFirebird = "sdbc:embedded:firebird"
Const cstMSAccess2003 = "MS Jet 0"
Const cstMSAccess2007 = "MS Jet 04."
Const cstMYSQL = "MySQL"
Const cstPOSTGRES = "PostgreSQL"
Const cstSQLITE = "SQLite"

 With com.sun.star.sdbc.DataType
  _ColumnTypesReference = Array( _
   .ARRAY _
   , .BIGINT _
   , .BINARY _
   , .BIT _
   , .BLOB _
   , .BOOLEAN _
   , .CHAR _
   , .CLOB _
   , .DATE _
   , .DECIMAL _
   , .DISTINCT _
   , .DOUBLE _
   , .FLOAT _
   , .INTEGER _
   , .LONGVARBINARY _
   , .LONGVARCHAR _
   , .NUMERIC _
   , .OBJECT _
   , .OTHER _
   , .REAL _
   , .REF _
   , .SMALLINT _
   , .SQLNULL _
   , .STRUCT _
   , .TIME _
   , .TIMESTAMP _
   , .TINYINT _
   , .VARBINARY _
   , .VARCHAR _
  )
 End With

 With Metadata
  sProduct = .getDatabaseProductName() & " " & .getDatabaseProductVersion
  Select Case True
   Case Len(sProduct) > Len(cstHSQLDB1) And Left(sProduct, Len(cstHSQLDB1)) = cstHSQLDB1
    _RDBMS = DBMS_HSQLDB1
    _ColumnTypesAlias = Array(0, -5, -2, 16, -4, 16, 1, -1, 91, 3, 0, 8, 6, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, 12)
    _BinaryStream = True
   Case Len(sProduct) > Len(cstHSQLDB2) And Left(sProduct, Len(cstHSQLDB2)) = cstHSQLDB2
    _RDBMS = DBMS_HSQLDB2
    _ColumnTypesAlias = Array(0, -5, -3, -7, 2004, 16, 1, 2005, 91, 3, 0, 8, 8, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -3, 12)
    _BinaryStream = True
   Case .URL = cstFirebird  ' Only embedded 3.0
    _RDBMS = DBMS_FIREBIRD
    _ColumnTypesAlias = Array(0, -5, -2, 16, 2004, 16, 1, 2005, 91, 3, 0, 8, 6, 4, -4, 2005, 2, 0, 0, 8, 0, 5, 0, 0, 92, 93, 4, 2004, 12)
    _BinaryStream = True
   Case Len(sProduct) > Len(cstMSAccess2007) And Left(sProduct, Len(cstMSAccess2007)) = cstMSAccess2007
    _RDBMS = DBMS_MSACCESS2007
    _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
    _BinaryStream = True
   Case Len(sProduct) > Len(cstMSAccess2003) And Left(sProduct, Len(cstMSAccess2003)) = cstMSAccess2003
    _RDBMS = DBMS_MSACCESS2003
    _ColumnTypesAlias = Array(0, 4, -2, 16, -2, 16, 12, 12, 93, 8, 0, 8, 6, 4, -3, 12, 2, 0, 0, 8, 0, 5, 0, 0, 93, 93, -6, -2, 12)
    _BinaryStream = True
   Case Len(sProduct) > Len(cstMYSQL) And Left(sProduct, Len(cstMYSQL)) = cstMYSQL
    _RDBMS = DBMS_MYSQL
    _ColumnTypesAlias = Array(0, -5, -2, -7, -4, -7, 1, -1, 91, 3, 0, 8, 8, 4, -4, -1, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, -6, -3, -1)
    _BinaryStream = False
   Case Len(sProduct) > Len(cstPOSTGRES) And Left(sProduct, Len(cstPOSTGRES)) = cstPOSTGRES
    _RDBMS = DBMS_POSTGRES
    _ColumnTypesAlias = Array(0, -5, -3, 16, -3, 16, 1, 12, 91, 8, 0, 8, 8, 4, -3, 12, 2, 0, 0, 7, 0, 5, 0, 0, 92, 93, 4, -3, 12)
    _BinaryStream = True
   Case Len(sProduct) > Len(cstSQLITE) And Left(sProduct, Len(cstSQLITE)) = cstSQLITE
    _RDBMS = DBMS_SQLITE
    _ColumnTypesAlias = Array(0, -5, -4, -7, -4, -7, 1, -1, 91, 8, 0, 8, 6, 4, -4, -1, 8, 0, 0, 8, 0, 5, 0, 0, 92, 93, -6, -4, 12)
    _BinaryStream = True
   Case Else
    _RDBMS = DBMS_UNKNOWN
    _BinaryStream = True
  End Select

  iInfo = -1
  Set oTypeInfo = MetaData.getTypeInfo()
  With oTypeInfo
   .next()
   Do While Not .isAfterLast() And iInfo < cstMaxInfo
    sName = .getString(1)
    lType = .getLong(2)
    If _RDBMS = DBMS_POSTGRES And (Left(sName, 1) <> "_" Or lType <> -1) Then  ' Skip
    Else
     iInfo = iInfo + 1
     _ColumnTypeNames(iInfo) = sName
     _ColumnTypes(iInfo) = lType
     _ColumnPrecisions(iInfo) = CLng(.getLong(3))
    End If
    .next()
   Loop
  End With
  ReDim Preserve _ColumnTypes(0 To iInfo)
  ReDim Preserve _ColumnTypeNames(0 To iInfo)
  ReDim Preserve _ColumnPrecisions(0 To iInfo)
 End With

End Sub   ' _LoadMetadata V1.6.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputBinaryToHTML() As String
' Converts Binary value to HTML compatible string

 _OutputBinaryToHTML = "&nbsp;"

End Function ' _OutputBinaryToHTML V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputBooleanToHTML(ByVal pbBool As Boolean) As String
' Converts input boolean value to HTML compatible string

 _OutputBooleanToHTML = Iif(pbBool, "&#x2714;", "&#x2716;")  ' ✔ and ✖

End Function ' _OutputBooleanToHTML V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputClassToHTML(ByVal pvArray As Variant) As String
' Formats classes attribute of <tr> and <td> tags

 If Not IsArray(pvArray) Then
  _OutputClassToHTML = ""
 ElseIf UBound(pvArray) < LBound(pvArray) Then
  _OutputClassToHTML = ""
 Else
  _OutputClassToHTML = " class=""" & Join(pvArray, " ") & """"
 End If

End Function ' _OutputClassToHTML V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputDataToHTML(ByRef pvTable As Variant, ByVal pvName As String, ByVal piFile As Integer _
         , ByRef Optional pvHeaders As Variant _
         , ByRef Optional pvData As Variant _
         ) As Boolean
' Write html tags around data found in pvTable
' Exit when error without execution stop (to avoid file remaining open ...)

Dim oTableRS As Object, vData() As Variant, i As Integer, j As Integer
Dim vFieldsBin() As Variant, iDataType As Integer, iNumRows As Integer, iNumFields As Integer, vDataCell As Variant
Dim bDataArray As Boolean, sHeader As String
Dim vTrClass() As Variant, vTdClass As Variant, iCountRows As Integer, iLastRow As Integer
Const cstMaxRows = 200
 On Local Error GoTo Error_Function

 bDataArray = IsNull(pvTable)
 Print #piFile, "  <table class=""dbdatatable"">"
 Print #piFile, "   <caption>" & pvName & "</caption>"

 vFieldsBin() = Array()
 If bDataArray Then
  Set oTableRS = Nothing
  iNumFields = UBound(pvHeaders) + 1
  ReDim vFieldsBin(0 To iNumFields - 1)
  For i = 0 To iNumFields - 1
   vFieldsBin(i) =  False
  Next i
 Else
  Set oTableRS = pvTable.OpenRecordset( , , dbReadOnly)
  iNumFields = oTableRS.Fields.Count
  ReDim vFieldsBin(0 To iNumFields - 1)
  With com.sun.star.sdbc.DataType
   For i = 0 To iNumFields - 1
    iDataType = oTableRS.Fields(i).DataType
    vFieldsBin(i) =  Utils._IsBinaryType(iDataType)
   Next i
  End With
 End If

 With oTableRS
  Print #piFile, "   <thead>"
  Print #piFile, "    <tr>"
  For i = 0 To iNumFields - 1
   If bDataArray Then sHeader = pvHeaders(i) Else sHeader = .Fields(i)._Name
   Print #piFile, "     <th scope=""col"">" & sHeader & "</th>"
  Next i
  Print #piFile, "    </tr>"
  Print #piFile, "   </thead>"
  Print #piFile, "   <tfoot>"
  Print #piFile, "   </tfoot>"

  Print #piFile, "   <tbody>"
  If bDataArray Then
   iLastRow = UBound(pvData, 2) + 1
  Else
   .MoveLast
   iLastRow = .RecordCount
   .MoveFirst
  End If
  iCountRows = 0
  Do While iCountRows < iLastRow
   If bDataArray Then
    iNumRows = iLastRow
   Else
    vData() = .GetRows(cstMaxRows)
    iNumRows = UBound(vData, 2) + 1
   End If
   For j = 0 To iNumRows - 1
    iCountRows = iCountRows + 1
    vTrClass() = Array()
    If iCountRows = 1 Then vTrClass() = _AddArray(vTrClass, "firstrow")
    If iCountRows = iLastRow Then vTrClass() = _AddArray(vTrClass, "lastrow")
    If (iCountRows Mod 2) = 0 Then vTrClass() = _AddArray(vTrClass, "even") Else vTrClass() = _AddArray(vTrClass, "odd")
    Print #piFile, "    <tr" & _OutputClassToHTML(vTrClass) & ">"
    For i = 0 To iNumFields - 1
     vTdClass() = Array()
     If i = 0 Then vTdClass() = _AddArray(vTdClass, "firstcol")
     If i = iNumFields - 1 Then vTdClass() = _AddArray(vTdClass, "lastcol")
     If Not vFieldsBin(i) Then
      If bDataArray Then vDataCell = pvData(i, j) Else vDataCell = vData(i, j)
      If vDataCell Is Nothing Then vDataCell = Null  ' Necessary because Null object has not a VarType = vbNull
      If VarType(vDataCell) = vbString Then ' Null string gives IsDate = True !
       If Len(vDataCell) > 0 And IsDate(vDataCell) Then vDataCell = CDate(vDataCell)
      End If
      Select Case VarType(vDataCell)
       Case vbEmpty, vbNull
        vTdClass() = _AddArray(vTdClass, "null")
        Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNullToHTML() & "</td>"
       Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal, vbUShort, vbULong, vbBigInt
        vTdClass() = _AddArray(vTdClass, "numeric")
        If vDataCell < 0 Then vTdClass() = _AddArray(vTdClass, "negative")
        Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputNumberToHTML(vDataCell) & "</td>"
       Case vbBoolean
        vTdClass() = _AddArray(vTdClass, "bool")
        If vDataCell = False Then vTdClass() = _AddArray(vTdClass, "false")
        Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBooleanToHTML(vDataCell) & "</td>"
       Case vbDate
        vTdClass() = _AddArray(vTdClass, "date")
        Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputDateToHTML(vDataCell) & "</td>"
       Case vbString
        vTdClass() = _AddArray(vTdClass, "char")
        Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputStringToHTML(vDataCell) & "</td>"
       Case Else
        Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _CStr(vDataCell) & "</td>"
      End Select
     Else    ' Binary fields
      Print #piFile, "     <td" & _OutputClassToHTML(vTdClass) & ">" & _OutputBinaryToHTML() & "</td>"
     End If
    Next i
    Print #piFile, "    </tr>"
   Next j
  Loop

  If Not bDataArray Then .mClose()
 End With
 Set oTableRS = Nothing

 Print #piFile, "   </tbody>"
 Print #piFile, "  </table>"
 _OutputDataToHTML = True

Exit_Function:
 Exit Function
Error_Function:
 TraceError(TRACEWARNING, Err, "_OutputDataToHTML", Erl)
 _OutputDataToHTML = False
 Resume Exit_Function
End Function ' _OutputDataToHTML V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputDateToHTML(ByVal psDate As Date) As String
' Converts input date to HTML compatible string

 _OutputDateToHTML = Format(psDate) ' With regional settings - Ignores time if = to 0

End Function ' _OutputDateToHTML V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputNullToHTML() As String
' Converts Null value to HTML compatible string

 _OutputNullToHTML = "&nbsp;"

End Function ' _OutputNullToHTML V1.4.0

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _OutputNumberToHTML(ByVal pvNumber As Variant, ByVal Optional piPrecision As Integer) As String
' Converts input number to HTML compatible string

Dim vNumber As Variant
 If IsMissing(piPrecision) Then piPrecision = -1
 If pvNumber = Int(pvNumber) Then
  vNumber = Int(pvNumber)
 Else
--> --------------------

--> maximum size reached

--> --------------------