Current File : //lib/libreoffice/share/basic/SFDatabases/SF_Dataset.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="SF_Dataset" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
REM === The SFDatabases library is one of the associated libraries. ===
REM === Full documentation is available on https://help.libreoffice.org/ ===
REM =======================================================================================================================
Option Compatible
Option ClassModule
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' SF_Dataset
''' ==========
''' A dataset represents a set of tabular data produced by a database.
''' In the user interface of LibreOffice a dataset corresponds with the data
''' displayed in a form or a data sheet (table, query).
''' To use datasets, the database instance must exist but the Base document may not be open.
'''
''' In the context of ScriptForge, a dataset may be created automatically by script code :
''' - at any moment => in this case the Base document may or may not be open.
''' - any SELECT SQL statement may define the dataset.
'''
''' The proposed API supports next main purposes:
''' - browse for- and backward through the dataset to get its content
''' - update any record with new values
''' - create new records or delete some.
''' So-called "CRUD" operations (create, read, update, delete).
'''
''' Service invocation:
''' A dataset is characterized by
''' - the parent database
''' - a table/query name or an SQL SELECT statement
''' - the DirectSQL option to bypass the processing of SQL by LibreOffice
''' - an optional filter
''' - an optional sorting order
''' 1) From a database class instance
''' Dim db As Object, FileName As String, Dataset As Object, Dataset2 As Object
''' Set db = CreateScriptService("SFDatabases.Database", FileName, , ReadOnly := False)
''' Set Dataset = db.CreateDataset("myTable", DirectSql := False, Filter := "[City]='Brussels'")
''' 2) From an existing dataset
''' Set Dataset2 = Dataset.CreateDataset(Filter := "[City]='Paris'")
'''
''' Dataset browsing with the MoveNext(), MovePrevious(), ... methods
''' After creation of the dataset, the current record is positioned BEFORE the first record.
''' Every MoveXXX() method returns False when no record could be retrieved, otherwise True.
''' When False, the current record is reset either in BOF or EOF positions.
''' Typically:
''' Set dataset = db.CreateDataset("myTable")
''' With Dataset
''' Do While .MoveNext()
''' ...
''' Loop
''' .CloseDataset()
''' End With
'''
''' Updates performance:
''' This module provides methods to update data stored in database tables.
''' Note that the proposed Update() and Insert() methods will always be
''' SLOWER or MUCH SLOWER than equivalent SQL statements.
''' Always privilege SQL when considering massive updates.
'''
''' Detailed user documentation:
''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/SF_Dataset.html?DbPAR=BASIC
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
REM ================================================================== EXCEPTIONS
' Error in the dataset's initial SQL statement
Private Const SQLSYNTAX2ERROR = "SQLSYNTAX2ERROR"
' The current record could not be determined
Private Const NOCURRENTRECORDERROR = "NOCURRENTRECORDERROR"
' Database is read-only. Method rejected
Private Const DBREADONLYERROR = "DBREADONLYERROR"
' Database fields update error
' Value to store does not fit the type of the field
' Field is not nullable and value = Null
' Field is not writable or autovalue
' Input file does not exist or is empty
' Field type is not supported
Private Const RECORDUPDATEERROR = "RECORDUPDATEERROR"
' The destination file exists and cannot be overwritten
Private Const FIELDEXPORTERROR = "FIELDEXPORTERROR"
REM ============================================================= PRIVATE MEMBERS
Private [Me] As Object
Private ObjectType As String ' Must be DATASET
Private ServiceName As String
Private _ParentDatabase As Object ' The parent SF_Database instance (must not be void)
Private _DatasetType As String ' TABLE, QUERY or SQL
Private _Command As String ' Table name, query name or SQL statement
Private _Sql As String ' Equivalent SQL command
Private _DirectSql As Boolean ' When True, SQL processed by RDBMS
Private _Filter As String ' WHERE clause without WHERE
Private _OrderBy As String ' ORDER BY clause without ORDER BY
Private _ReadOnly As Boolean ' When True, updates are forbidden
Private _RowSet As Object ' com.sun.star.sdb.RowSet
Private _Fields As Variant ' Array of field names
Private _UpdatableFields As Variant ' Array of updatable field names
Private _DefaultValues As Variant ' Array of field default values // _Fields
Private _AutoValue As Long ' Index of AutoValue field. None = -1
Private _DatasetIndex As Long ' Index of the dataset in the _Datasets array of the parent database
REM ============================================================ MODULE CONSTANTS
REM ====================================================== CONSTRUCTOR/DESTRUCTOR
REM -----------------------------------------------------------------------------
Private Sub Class_Initialize()
Set [Me] = Nothing
ObjectType = "DATASET"
ServiceName = "SFDatabases.Dataset"
Set _ParentDatabase = Nothing
_DatasetType = ""
_Command = ""
_DirectSql = False
_Filter = ""
_OrderBy = ""
_ReadOnly = False
Set _RowSet = Nothing
_Fields = Array()
_UpdatableFields = Array()
_DefaultValues = Array()
_AutoValue = -1
_DatasetIndex = -1
End Sub ' SFDatabases.SF_Dataset Constructor
REM -----------------------------------------------------------------------------
Private Sub Class_Terminate()
Call Class_Initialize()
End Sub ' SFDatabases.SF_Dataset Destructor
REM -----------------------------------------------------------------------------
Public Function Dispose() As Variant
Call Class_Terminate()
Set Dispose = Nothing
End Function ' SFDatabases.SF_Dataset Explicit Destructor
REM ================================================================== PROPERTIES
REM -----------------------------------------------------------------------------
Property Get BOF() As Variant
''' The BOF property returns True if the current record position is before the first record
''' in the Dataset, otherwise it returns False.
Bof = _PropertyGet("BOF")
End Property ' SFDatabases.SF_Dataset.BOF (get)
REM -----------------------------------------------------------------------------
Property Let BOF(Optional ByVal pvBOF As Variant)
''' Set the updatable property BOF.
''' Setting BOF to True positions the current record before the first record.
''' Setting it to False is ignored. True is the only relevant value.
_PropertySet("BOF", pvBOF)
End Property ' SFDatabases.SF_Dataset.BOF (let)
REM -----------------------------------------------------------------------------
Property Get DefaultValues() As Variant
''' Returns a dictionary (field name => default value).
''' The database field type is converted to the corresponding Basic/Python variable types.
''' When undefined: returns either Null (field is nullable) or Empty
''' The output dictionary should be disposed by the user script
DefaultValues = _PropertyGet("DefaultValues")
End Property ' SFDatabases.SF_Dataset.DefaultValues (get)
REM -----------------------------------------------------------------------------
Property Get EOF() As Variant
''' The EOF property returns True if the current record position is after the last record
''' in the Dataset, otherwise it returns False.
EOF = _PropertyGet("EOF")
End Property ' SFDatabases.SF_Dataset.EOF (get)
REM -----------------------------------------------------------------------------
Property Let EOF(Optional ByVal pvEOF As Variant)
''' Set the updatable property EOF.
''' Setting EOF to True positions the current record after the last record.
''' Setting it to False is ignored. True is the only relevant value.
_PropertySet("EOF", pvEOF)
End Property ' SFDatabases.SF_Dataset.EOF (let)
REM -----------------------------------------------------------------------------
Property Get Fields() As Variant
''' Returns the list of the field names contained in the dataset
Fields = _PropertyGet("Fields")
End Property ' SFDatabases.SF_Dataset.Fields (get)
REM -----------------------------------------------------------------------------
Property Get Filter() As Variant
''' The Filter is a SQL WHERE clause without the WHERE keyword
Filter = _PropertyGet("Filter")
End Property ' SFDatabases.SF_Dataset.Filter (get)
REM -----------------------------------------------------------------------------
Property Get OrderBy() As Variant
''' The OrderBy is an SQL ORDER BY clause without the ORDER BY keyword
OrderBy = _PropertyGet("OrderBy")
End Property ' SFDatabases.SF_Dataset.OrderBy (get)
REM -----------------------------------------------------------------------------
Property Get ParentDatabase() As Object
''' Returns the database instance to which the dataset belongs
Set ParentDatabase = _PropertyGet("ParentDatabase")
End Property ' SFDatabases.SF_Dataset.ParentDatabase
REM -----------------------------------------------------------------------------
Property Get RowCount() As Long
''' Returns the number of records present in the dataset
''' When that number exceeds a certain limit, its determination requires
''' that the whole dataset has been read first, up to its last row.
''' For huge datasets, this can represent a significant performance cost.
RowCount = _PropertyGet("RowCount")
End Property ' SFDatabases.SF_Dataset.RowCount
REM -----------------------------------------------------------------------------
Property Get RowNumber() As Long
''' Returns the sequence number >= 1 of the current record. Returns 0 if unknown.
RowNumber = _PropertyGet("RowNumber")
End Property ' SFDatabases.SF_Dataset.RowNumber
REM -----------------------------------------------------------------------------
Property Get Source() As String
''' Returns the source of the data: table name, query name or sql statement
Source = _PropertyGet("Source")
End Property ' SFDatabases.SF_Dataset.Source
REM -----------------------------------------------------------------------------
Property Get SourceType() As String
''' Returns the type of source of the data: TABLE, QUERY or SQL
SourceType = _PropertyGet("SourceType")
End Property ' SFDatabases.SF_Dataset.SourceType
REM -----------------------------------------------------------------------------
Property Get UpdatableFields() As Variant
''' Returns the list of the names of the updatable fields contained in the dataset
UpdatableFields = _PropertyGet("UpdatableFields")
End Property ' SFDatabases.SF_Dataset.UpdatableFields (get)
REM -----------------------------------------------------------------------------
Property Get Values() As Variant
''' Returns a dictionary (field name => field value) applied on the current record
''' Binary fields ? => their length is returned
''' The output dictionary should be disposed by the user script
''' Returns Nothing when there is no current record
Values = _PropertyGet("Values")
End Property ' SFDatabases.SF_Dataset.Values (get)
REM -----------------------------------------------------------------------------
Property Get XRowSet() As Object
''' Returns the com.sun.star.sdb.RowSet UNO object representing the dataset
XRowSet = _PropertyGet("XRowSet")
End Property ' SFDocuments.SF_Document.XRowSet
REM ===================================================================== METHODS
REM -----------------------------------------------------------------------------
Public Function CloseDataset() As Boolean
''' Close the actual dataset
''' Args:
''' Returns:
''' True when successful
''' Examples:
''' dataset.CloseDataset()
Dim bClose As Boolean ' Return value
Const cstThisSub = "SFDatabases.Sataset.CloseDataset"
Const cstSubArgs = ""
If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bClose = False
Check:
SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
Try:
If Not IsNull(_RowSet) Then
With _RowSet
.close()
.dispose()
End With
If _DatasetIndex >= 0 Then Set _ParentDatabase._Datasets(_DatasetIndex) = Nothing
Dispose()
bClose = True
End If
Finally:
CloseDataset = bClose
SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.CloseDataset
REM -----------------------------------------------------------------------------
Public Function CreateDataset(Optional ByVal Filter As Variant _
, Optional ByVal OrderBy As Variant _
) As Object
''' Create and return a Dataset class instance based on the actual Dataset
''' Filter and OrderBy properties may be redefined.
''' Args:
''' Filter: an additional condition that records must match, expressed
''' as a valid SQL WHERE clause without the WHERE keyword
''' Default: the filter applied on the actual dataset.
''' OrderBy: the ordering of the dataset expressed as a valid SQL ORDER BY clause
''' without the ORDER BY keywords.
''' Default: the same sorting order as the actual dataset.
''' Returns:
''' A SF_Dataset instance or Nothing when not successful
''' Exceptions
''' SQLSYNTAX2ERROR The given SQL statement is incorrect
''' Examples:
''' Dim ds1 As Object, ds2 As Object, ds3 As Object, ds4 As Object
''' Set ds1 = dataset.CreateDataset() ' dataset and ds1 contain the same set of data
''' Set ds2 = dataset.CreateDataset(Filter := "") ' Suppress the current filter
''' Set ds3 = dataset.CreateDataset(Filter := "[Name] LIKE 'A%'")
''' ' Define a new filter
''' Set ds4 = dataset.CreateDataset(Filter := "(" & dataset.Filter & ") AND [Name] LIKE 'A%'")
''' ' Combine actual filter with an additional condition
Dim oDataset As Object ' Return value
Const cstThisSub = "SFDatabases.Dataset.CreateDataset"
Const cstSubArgs = "[Filter=""...filter...""], [OrderBy=""...orderby...""]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
Set oDataset = Nothing
Check:
If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = _Filter
If IsMissing(OrderBy) Or IsEmpty(OrderBy) Then OrderBy = _OrderBy
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(Filter, "Filter", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(OrderBy, "OrderBy", V_STRING) Then GoTo Finally
End If
Try:
Set oDataset = New SF_Dataset
With oDataset
Set .[Me] = oDataset
Set ._ParentDatabase = _ParentDatabase
._DatasetType = _DatasetType
._Command = _Command
._Sql = _Sql
._DirectSql = _DirectSql
._Filter = _ParentDatabase._ReplaceSquareBrackets(Filter)
._OrderBy = _ParentDatabase._ReplaceSquareBrackets(OrderBy)
._ReadOnly = _ReadOnly
' If creation not successful, then cancel everything
If Not ._Initialize() Then Set oDataset = .Dispose()
End With
Finally:
Set CreateDataset = oDataset
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.CreateDataset
REM -----------------------------------------------------------------------------
Public Function Delete() As Boolean
''' Deletes the current record, from the dataset and from the database.
''' The cursor is set on the record following immediately the deleted record,
''' or after the last record if the deleted one was the last one.
''' Args:
''' Returns:
''' True when successful
''' Exceptions:
''' DBREADONLYERROR The actual method cannot be executed
''' NOCURRENTRECORDERROR The current record could not be determined
''' Examples
''' dataset.Delete()
Dim bDelete As Boolean ' Return value
Dim bLast As Boolean ' True when the current record is the last one
Const cstThisSub = "SFDatabases.Dataset.Delete"
Const cstSubArgs = ""
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bDelete = False
With _RowSet
Check:
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
If _ReadOnly Then GoTo CatchreadOnly
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent
Try:
bLast = .isLast()
.deleteRow()
bDelete = .rowDeleted
If bLast Then .afterLast() Else .next()
End With
Finally:
Delete = bDelete
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchCurrent:
ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR)
GoTo Finally
CatchReadOnly:
ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR)
GoTo Finally
End Function ' SFDatabases.SF_Dataset.Delete
REM -----------------------------------------------------------------------------
Public Function ExportValueToFile(Optional ByVal FieldName As Variant _
, Optional ByVal FileName As Variant _
, Optional ByVal Overwrite As Variant _
) As Boolean
''' Export the content of a binary field to a given file
''' Args:
''' FieldName: the name of a binary field as a case-sensitive string
''' FileName: the destination file name in ScriptForge.FileSystem service notation
''' Overwrite: when True, the destination file may be overwritten
''' Returns:
''' True when successful
''' Exceptions:
''' NOCURRENTRECORDERROR The current record could not be determined
''' FIELDEXPORTERROR The destination has its readonly attribute set or overwriting rejected
Dim bExport As Variant ' Return value
Dim oSfa As Object ' com.sun.star.ucb.SimpleFileAccess
Dim sFile As String ' Alias of FileName
Dim lColIndex As Long ' Column index
Dim oColumn As Object ' com.sun.star.sdb.ODataColumn
Dim oStream As Object ' com.sun.star.io.XInputStream
Const cstThisSub = "SFDatabases.Dataset.ExportValueToFile"
Const cstSubArgs = "FieldName, FileName, [Overwrite=False]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bExport = False
Check:
If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(FieldName, "FieldName", V_STRING, _Fields) Then GoTo Catch
If Not ScriptForge.SF_Utils._ValidateFile(FileName, "FileName") Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(Overwrite, "Overwrite", ScriptForge.V_BOOLEAN) Then GoTo Finally
End If
' Check destination file overwriting
sFile = ConvertToUrl(FileName)
Set oSfa = ScriptForge.SF_Utils._GetUNOService("FileAccess")
If oSfa.exists(sFile) Then
If Not Overwrite Then GoTo CatchFile
If oSfa.isReadonly(sFile) Then GoTo CatchFile
End If
' Check the current record
With _RowSet
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent
End With
Try:
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, FieldName, CaseSensitive := True)
If lColIndex >= 0 Then
' Establish the input stream
Set oColumn = _RowSet.Columns.getByIndex(lColIndex)
With com.sun.star.sdbc.DataType
Select Case oColumn.Type
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
Set oStream = oColumn.getBinaryStream()
'Case .VARCHAR, .LONGVARCHAR, .CLOB
Case Else
Set oStream = Nothing
End Select
End With
' Process NULL value
If Not IsNull(oStream) And oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then
If oColumn.wasNull() Then
oStream.closeInput()
Set oStream = Nothing
End If
End If
' Dump field into file
If Not IsNull(oStream) Then
If oStream.getLength() > 0 Then
oSfa.writeFile(sFile, oStream)
End If
oStream.closeInput()
End If
End If
bExport = True
Finally:
ExportValueToFile = bExport
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchCurrent:
ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR)
GoTo Finally
CatchFile:
ScriptForge.SF_Exception.RaiseFatal(FIELDEXPORTERROR, "FileName", FileName, "Overwrite", Overwrite)
GoTo Finally
End Function ' SFDatabases.SF_Dataset.ExportValueToFile
REM -----------------------------------------------------------------------------
Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
''' Return the actual value of the given property
''' Args:
''' PropertyName: the name of the property as a string
''' Returns:
''' The actual value of the propRATTCerty
''' If the property does not exist, returns Null
Const cstThisSub = "SFDatabases.Dataset.GetProperty"
Const cstSubArgs = ""
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
GetProperty = Null
Check:
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
End If
Try:
GetProperty = _PropertyGet(PropertyName)
Finally:
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.GetProperty
REM -----------------------------------------------------------------------------
Public Function GetRows(Optional ByVal Header As Variant _
, Optional ByVal MaxRows As Variant _
) As Variant
''' Return the content of the dataset as an array
''' This operation can be done in chunks:
''' - The collected data starts at the current row + 1
''' - When MaxRows > 0 then the collection stops after this limit has been reached.
''' Otherwise all the data up to the end is collected.
''' Args:
''' Header: When True, a header row is inserted at the top of the array with the column names. Default = False
''' MaxRows: The maximum number of returned rows. If absent, all records up to the end are returned
''' Returns:
''' a 2D array(row, column), even if only 1 column and/or 1 record
''' an empty array if no records returned
''' Example:
''' Dim a As Variant, lMaxRows As Long
''' lMaxRows = 100
''' Do
''' a = dataset.GetRows(Header := True, MaxRows := lMaxRows)
''' If UBound(a, 1) >= 0 Then
''' ' ...
''' End If
''' Loop Until UBound(a, 1) < lMaxRows ' Includes empty array - Use ... < lMaxRows - 1 when Header := False
Dim vResult As Variant ' Return value
Dim lCols As Long ' Number of columns
Dim lRows As Long ' Number of rows
Dim oColumns As Object ' Collection of com.sun.star.sdb.ODataColumn
Dim bRead As Boolean ' When True, next record has been read successfully
Dim i As Long
Const cstThisSub = "SFDatabases.Dataset.GetRows"
Const cstSubArgs = "[Header=False], [MaxRows=0]"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
vResult = Array()
Check:
If IsMissing(Header) Or IsEmpty(Header) Then Header = False
If IsMissing(MaxRows) Or IsEmpty(MaxRows) Then MaxRows = 0
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(Header, "Header", ScriptForge.V_BOOLEAN) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(MaxRows, "MaxRows", ScriptForge.V_NUMERIC) Then GoTo Finally
End If
If MaxRows < 0 Then MaxRows = 1
Try:
With _RowSet
' Check if there is any data to collect
bRead = .next()
If bRead Then
'Initialize output array with header row
Set oColumns = .getColumns()
lCols = oColumns.Count - 1
If Header Then
lRows = 0
ReDim vResult(0 To lRows, 0 To lCols)
For i = 0 To lCols
vResult(lRows, i) = oColumns.getByIndex(i).Name
Next i
If MaxRows > 0 Then MaxRows = MaxRows + 1
Else
lRows = -1
End If
' Load data
Do While bRead
lRows = lRows + 1
If lRows = 0 Then
ReDim vResult(0 To lRows, 0 To lCols)
Else
ReDim Preserve vResult(0 To lRows, 0 To lCols)
End If
For i = 0 To lCols
vResult(lRows, i) = _ParentDatabase._GetColumnValue(_RowSet, i + 1)
Next i
If MaxRows = 0 Or lRows < MaxRows - 1 Then bRead = .next() Else bRead = False
Loop
Else
vResult = Array()
End If
End With
Finally:
GetRows = vResult
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.GetRows
REM -----------------------------------------------------------------------------
Public Function GetValue(Optional ByVal FieldName As Variant) As Variant
''' Returns the value of a given field in the current record
''' Args:
''' FieldName: the name of a field as a case-sensitive string
''' Returns:
''' The found value as a Basic variable
''' The length of binary fields is returned,not their content.
''' Exceptions:
''' NOCURRENTRECORDERROR The current record could not be determined
Dim vValue As Variant ' Return value
Dim lColIndex As Long ' Column index
Const cstThisSub = "SFDatabases.Dataset.GetValue"
Const cstSubArgs = "FieldName"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
vValue = Null
Check:
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(FieldName, "FieldName", V_STRING, _Fields) Then GoTo Catch
End If
With _RowSet
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent
End With
Try:
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, FieldName, CaseSensitive := True)
If lColIndex >= 0 Then vValue = _ParentDatabase._GetColumnValue(_RowSet, lColIndex + 1)
Finally:
GetValue = vValue
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchCurrent:
ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR)
GoTo Finally
End Function ' SFDatabases.SF_Dataset.GetValue
REM -----------------------------------------------------------------------------
Public Function Insert(ParamArray pvArgs As Variant) As Long
''' Create a new record in the database and initialize its fields.
''' The current record is unchanged. The new record is inserted at the end of the dataset.
''' Updatable fields not mentioned in the arguments are initialized with their default value.
''' Args:
''' Either a single argument
''' UpdatesList: a ScriptForge.SF_Dictionary object listing pairs of key/item where
''' the key = an updatable field
''' the item = its value
''' or an even number of arguments alternating
''' FieldName: an updatable field
''' FieldValue: its value
''' The first form is particularly convenient in Python scripts
''' Returns:
''' When the primary key is an AutoValue field: the autovalue of the new record
''' (to facilitate the use of the new primary key in foreign keys)
''' Otherwise: 0 (= successful), -1 (= not successful)
''' Exceptions:
''' DBREADONLYERROR The actual method cannot be executed
''' RECORDUPDATEERROR When value to store does not fit the type of the field
''' or when field is not nullable and value = Null
''' or when field is not writable or is an autovalue
''' or when input file does not exist or is empty
''' or when field type is not supported
''' TABLEPRIMARYKEYERROR Primary key duplication
''' Examples
''' (Basic)
''' Dim newID As Long
''' newID = dataset.Insert("LastName", "Doe", "FirstName", "John")
''' ' ... is equivalent to:
''' Dim dict As Object, newID As Long
''' Set dict = CreateScriptService("ScriptForge.Dictionary")
''' dict.Add("LastName", "Doe")
''' dict.Add("FirstName", "John")
''' newID = dataset.Insert(dict)
''' (Python) - next statements are equivalent
''' newid = dataset.Insert('LastName', 'Doe', 'FirstName', 'John')
''' newid = dataset.Insert({'LastName': 'Doe', 'FirstName': 'John'})
''' newid = dataset.Insert(dict(LastName = 'Doe', FirstName = 'John'))
''' newid = dataset.Insert(LastName = 'Doe', FirstName = 'John')
Dim lInsert As Long ' Return value
Dim sSubArgs As String ' Alias of cstSubArgs
Dim sField As String ' A single field name
Dim oUpdates As Object ' A SF_Dictionary object
Dim lColIndex As Long ' Column index
Dim vKeys As Variant ' List of keys in the dictionary
Dim sKey As String ' A single key in vKeys
Dim i As Long
Const cstThisSub = "SFDatabases.Dataset.Insert"
Const cstSubArgs1 = "UpdatesList"
Const cstSubArgs2 = "FieldName1, FieldValue1, [FieldName2, FieldValue2], ..."
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
lInsert = -1
Check:
If UBound(pvArgs) = 0 Then ' Dictionary case
sSubArgs = cstSubArgs1
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(pvArgs(0), "UpdatesList", ScriptForge.V_OBJECT) Then GoTo Catch
End If
Set oUpdates = pvArgs(0)
Else
sSubArgs = cstSubArgs2 ' Arguments list case
ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs)
For i = 0 To UBound(pvArgs) Step 2
If Not ScriptForge.SF_Utils._Validate(pvArgs(i), "FieldName" & i, V_STRING, _UpdatableFields) Then GoTo Catch
Next i
End If
If _ReadOnly Then GoTo CatchReadOnly
Try:
With _RowSet
' Initialize the insertion row
.moveToInsertRow()
' Initial storage of default values
For Each sField In _UpdatableFields
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, sField, CaseSensitive := True)
_SetColumnValue(lColIndex, _DefaultValues(lColIndex))
Next sField
If UBound(pvArgs) = 0 Then
With oUpdates
vKeys = .Keys
For Each sKey in vKeys
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, sKey, CaseSensitive := True)
If lColIndex >= 0 Then
_SetColumnValue(lColIndex, .Item(sKey))
Else ' To force an error
If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch
End If
Next sKey
End With
Else
For i = 0 To UBound(pvArgs) Step 2
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, pvArgs(i), CaseSensitive := True)
If lColIndex >= 0 Then
If i < UBound(pvArgs) Then _SetColumnValue(lColIndex, pvArgs(i + 1))
Else ' To force an error
If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch
End If
Next i
End If
.insertRow()
' Compute the return value: either 0 or the new content of the pre-identified AUtoValue field
If _AutoValue < 0 Then lInsert = 0 Else lInsert = _ParentDatabase._GetColumnValue(_RowSet, _AutoValue + 1)
.moveToCurrentRow()
End With
Finally:
Insert = lInsert
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchReadOnly:
ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR)
GoTo Finally
End Function ' SFDatabases.SF_Dataset.Insert
REM -----------------------------------------------------------------------------
Public Function Methods() As Variant
''' Return the list of public methods of the Model service as an array
Methods = Array( _
"CloseDataset" _
, "CreateDataset" _
, "Delete" _
, "ExportValueToFile" _
, "GetRows" _
, "GetValue" _
, "Insert" _
, "MoveFirst" _
, "MoveLast" _
, "MoveNext" _
, "MovePrevious" _
, "Reload" _
, "Update" _
)
End Function ' SFDatabases.SF_Dataset.Methods
REM -----------------------------------------------------------------------------
Public Function MoveFirst() As Boolean
''' Move the cursor to the 1st record
''' Args:
''' Returns:
''' False when the Move was unsuccessful
''' When False the cursor is reset before the first record
Dim bMove As Boolean ' Return value
Const cstThisSub = "SFDatabases.Dataset.MoveFirst"
Const cstSubArgs = ""
Check:
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
Try:
with _RowSet
bMove = .first()
If Not bMove Then .beforeFirst()
End With
Finally:
MoveFirst = bMove
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.MoveFirst
REM -----------------------------------------------------------------------------
Public Function MoveLast() As Boolean
''' Move the cursor to the last record
''' Args:
''' Returns:
''' False when the Move was unsuccessful
''' When False the cursor is reset before the first record
Dim bMove As Boolean ' Return value
Const cstThisSub = "SFDatabases.Dataset.MoveLast"
Const cstSubArgs = ""
Check:
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
Try:
with _RowSet
bMove = .last()
If Not bMove Then .beforeFirst()
End With
Finally:
MoveLast = bMove
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.MoveLast
REM -----------------------------------------------------------------------------
Public Function MoveNext(Optional ByVal Offset As Variant) As Boolean
''' Move the cursor N records forward. Deleted records are skipped.
''' Args:
''' Offset: number of records to go forward (may be negative). Default = 1
''' Returns:
''' False when the Move was unsuccessful
''' When False the cursor is reset before the first record when Offset > 0, after the last record otherwise
''' Examples:
''' dataset.MoveNext(3) ' 3 records forward
''' dataset.MoveNext(-1) ' equivalent to MovePrevious()
Dim bMove As Boolean ' Return value
Dim lRow As Long ' Row number
Const cstThisSub = "SFDatabases.Dataset.MoveNext"
Const cstSubArgs = "[Offset=1]"
Check:
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Catch
End If
Try:
with _RowSet
Select Case Offset
Case 0 : bMove = True
Case 1 : bMove = .next()
Case -1 : bMove = .previous()
Case > 1 : bMove = .relative(Offset) ' RowSet.relative() stops at boundary when moving forward only !?
Case Else ' < -1
lRow = .Row()
If lRow > Abs(Offset) Then bMove = .relative(Offset) Else bMove = False
End Select
If bMove Then
If .rowDeleted() Then
If Offset >= 0 Then bMove = MoveNext() Else bMove = MovePrevious()
End If
End If
End With
Finally:
MoveNext = bMove
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.MoveNext
REM -----------------------------------------------------------------------------
Public Function MovePrevious(Optional ByVal Offset As Variant) As Boolean
''' Move the cursor N records backward. Deleted records are skipped.
''' Args:
''' Offset: number of records to go backward (may be negative). Default = 1
''' Returns:
''' False when the Move was unsuccessful
''' When False the cursor is reset before the first record
''' Examples:
''' dataset.MovePrevious(3) ' 3 records backward
''' dataset.MovePrevious(-1) ' equivalent to MoveNext()
Dim bMove As Boolean ' Return value
Dim lRow As Long ' Row number
Const cstThisSub = "SFDatabases.Dataset.MovePrevious"
Const cstSubArgs = "[Offset=1]"
Check:
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
If IsMissing(Offset) Or IsEmpty(Offset) Then Offset = 1
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(Offset, "Offset", ScriptForge.V_NUMERIC) Then GoTo Catch
End If
Try:
with _RowSet
Select Case Offset
Case 0 : bMove = True
Case 1 : bMove = .previous()
Case -1 : bMove = .next()
Case < -1 : bMove = .relative(- Offset) ' RowSet.relative() stops at boundary when moving forward only !?
Case Else ' > 1
lRow = .Row()
If lRow > Offset Then bMove = .relative(- Offset) Else bMove = False
End Select
If bMove Then
If .rowDeleted() Then
If Offset < 0 Then bMove = MoveNext() Else bMove = MovePrevious()
End If
End If
End With
Finally:
MovePrevious = bMove
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.MovePrevious
REM -----------------------------------------------------------------------------
Public Function Properties() As Variant
''' Return the list or properties of the Model class as an array
Properties = Array( _
"BOF" _
, "DefaultValues" _
, "EOF" _
, "Fields" _
, "Filter" _
, "OrderBy" _
, "ParentDatabase" _
, "RowCount" _
, "RowNumber" _
, "Source" _
, "SourceType" _
, "UpdatableFields" _
, "Values" _
, "XRowSet" _
)
End Function ' SFDatabases.SF_Dataset.Properties
REM -----------------------------------------------------------------------------
Public Function Reload(Optional ByVal Filter As Variant _
, Optional ByVal OrderBy As Variant _
) As Boolean
''' Reload the dataset from the database.
''' Useful in particular after record deletions and insertions.
''' Filter and OrderBy properties may be redefined.
''' The cursor is reset before the first record.
''' Args:
''' Filter: a condition that records must match, expressed
''' as a valid SQL WHERE clause without the WHERE keyword
''' Default: the actual filter is left unchanged.
''' OrderBy: the ordering of the dataset expressed as a valid SQL ORDER BY clause
''' without the ORDER BY keywords.
''' Default: the actual sorting order is left unchanged.
''' Returns:
''' True when successful
''' Exceptions
''' SQLSYNTAX2ERROR The given SQL statement is incorrect
''' Examples:
''' dataset.Reload() ' dataset is refreshed
''' dataset.Reload(Filter := "") ' Suppress the current filter
''' dataset.Reload(Filter := "[Name] LIKE 'A%'")
''' ' Define a new filter
''' dataset.Reload(Filter := "(" & dataset.Filter & ") AND [Name] LIKE 'A%'")
''' ' Combine actual filter with an additional condition
Dim bReload As Boolean ' Return value
Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements
Const cstThisSub = "SFDatabases.Dataset.Reload"
Const cstSubArgs = "[Filter=""...filter...""], [OrderBy=""...orderby...""]"
bErrorHandler = ScriptForge.SF_Utils._ErrorHandling()
If bErrorHandler Then On Local Error GoTo Catch
bReload = False
Check:
If IsMissing(Filter) Or IsEmpty(Filter) Then Filter = _Filter
If IsMissing(OrderBy) Or IsEmpty(OrderBy) Then OrderBy = _OrderBy
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(Filter, "Filter", V_STRING) Then GoTo Finally
If Not ScriptForge.SF_Utils._Validate(OrderBy, "OrderBy", V_STRING) Then GoTo Finally
End If
Try:
If Len(Filter) > 0 Then _Filter = _ParentDatabase._ReplaceSquareBrackets(Filter) Else _Filter = ""
If Len(OrderBy) > 0 Then _OrderBy = _ParentDatabase._ReplaceSquareBrackets(OrderBy) Else _OrderBy = ""
With _RowSet
.Filter = _Filter
.ApplyFilter = ( Len(_Filter) > 0 )
.Order = _OrderBy
If bErrorhandler Then On Local Error GoTo CatchSql
.execute()
End With
bReload = True
Finally:
Reload = bReload
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchSql:
On Local Error GoTo 0
ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAX2ERROR, _Sql, "WHERE " & _Filter, "ORDER BY " & _OrderBy)
GoTo Catch
End Function ' SFDatabases.SF_Dataset.Reload
REM -----------------------------------------------------------------------------
Public Function SetProperty(Optional ByVal PropertyName As Variant _
, Optional ByRef Value As Variant _
) As Boolean
''' Set a new value to the given property
''' Args:
''' PropertyName: the name of the property as a string
''' Value: its new value
''' Exceptions
''' ARGUMENTERROR The property does not exist
Const cstThisSub = "SFDatabases.Dataset.SetProperty"
Const cstSubArgs = "PropertyName, Value"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
SetProperty = False
Check:
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
End If
Try:
SetProperty = _PropertySet(PropertyName, Value)
Finally:
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset.SetProperty
REM -----------------------------------------------------------------------------
Public Function Update(ParamArray pvArgs As Variant) As Boolean
''' Updates a set of fields in the current record
''' Args:
''' Either a single argument
''' UpdatesList: a ScriptForge.SF_Dictionary object listing pairs of key/item where
''' the key = an updatable field
''' the item = its new value
''' or an even number of arguments alternating
''' FieldName: an updatable field
''' FieldValue: its new value
''' The first form is particularly convenient in Python scripts
''' Returns:
''' True when successful
''' Exceptions:
''' DBREADONLYERROR The actual method cannot be executed
''' RECORDUPDATEERROR When value to store does not fit the type of the field
''' or when field is not nullable and value = Null
''' or when field is not writable or is an autovalue
''' or when input file does not exist or is empty
''' or when field type is not supported
''' NOCURRENTRECORDERROR The current record could not be determined
''' Examples
''' (Basic)
''' dataset.Update("LastName", "Doe", "FirstName", "John")
''' ' ... is equivalent to:
''' Dim dict As Object
''' Set dict = CreateScriptService("ScriptForge.Dictionary")
''' dict.Add("LastName", "Doe")
''' dict.Add("FirstName", "John")
''' dataset.Update(dict)
''' (Python) - next statements are equivalent
''' dataset.Update({'LastName': 'Doe', 'FirstName': 'John'})
''' dataset.Update(dict(LastName = 'Doe', FirstName = 'John'))
''' dataset.Update(LastName = 'Doe', FirstName = 'John')
Dim bUpdate As Boolean ' Return value
Dim sSubArgs As String ' Alias of cstSubArgs
Dim oUpdates As Object ' A SF_Dictionary object
Dim lColIndex As Long ' Column index
Dim vKeys As Variant ' List of keys in the dictionary
Dim sKey As String ' A single key in vKeys
Dim i As Long
Const cstThisSub = "SFDatabases.Dataset.Update"
Const cstSubArgs1 = "UpdatesList"
Const cstSubArgs2 = "FieldName1, FieldValue1, [FieldName2, FieldValue2], ..."
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bUpdate = False
Check:
If UBound(pvArgs) = 0 Then ' Dictionary case
sSubArgs = cstSubArgs1
If ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs) Then
If Not ScriptForge.SF_Utils._Validate(pvArgs(0), "UpdatesList", ScriptForge.V_OBJECT) Then GoTo Catch
End If
Set oUpdates = pvArgs(0)
Else
sSubArgs = cstSubArgs2 ' Arguments list case
ScriptForge.SF_Utils._EnterFunction(cstThisSub, sSubArgs)
For i = 0 To UBound(pvArgs) Step 2
If Not ScriptForge.SF_Utils._Validate(pvArgs(i), "FieldName" & i, V_STRING, _UpdatableFields) Then GoTo Catch
Next i
End If
If _ReadOnly Then GoTo CatchReadOnly
With _RowSet
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then GoTo CatchCurrent
End With
Try:
If UBound(pvArgs) = 0 Then
With oUpdates
vKeys = .Keys
For Each sKey in vKeys
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, sKey, CaseSensitive := True)
If lColIndex >= 0 Then
_SetColumnValue(lColIndex, .Item(sKey))
Else ' To force an error
If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch
End If
Next sKey
End With
Else
For i = 0 To UBound(pvArgs) Step 2
lColIndex = ScriptForge.SF_Array.IndexOf(_Fields, pvArgs(i), CaseSensitive := True)
If lColIndex >= 0 Then
If i < UBound(pvArgs) Then _SetColumnValue(lColIndex, pvArgs(i + 1))
Else ' To force an error
If Not ScriptForge.SF_Utils._Validate(sKey, "FieldName", V_STRING, _UpdatableFields) Then GoTo Catch
End If
Next i
End If
If _RowSet.IsModified Then _RowSet.updateRow()
bUpdate = True
Finally:
Update = bUpdate
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
CatchCurrent:
ScriptForge.SF_Exception.RaiseFatal(NOCURRENTRECORDERROR)
GoTo Finally
CatchReadOnly:
ScriptForge.SF_Exception.RaiseFatal(DBREADONLYERROR)
GoTo Finally
End Function ' SFDatabases.SF_Dataset.Update
REM =========================================================== PRIVATE FUNCTIONS
REM -----------------------------------------------------------------------------
Private Function _ConvertDefaultValue(ByRef poColumn As Object) As Variant
''' Default values of table fields are stored in the Base file or in the database as strings.
''' The actual method converts those strings into a Basic native type.
''' Usage: facilitate the initialization of new records
''' Args:
''' poColumn: a com.sun.star.sdb.ODataColumn UNO object
''' Returns
''' The default value for the column expressed as a string, a number, a date, ...
''' Nullable columns have probably a Null default value.
Dim sValue As String ' The default value as a string
Dim vValue As Variant ' The default value as a native Basic type
Dim SESSION As Object : Set SESSION = ScriptForge.SF_Session
Try:
With poColumn
' Determine the default value as a string
If SESSION.HasUnoProperty(poColumn, "DefaultValue") Then ' Default value in database set via SQL statement
sValue = .DefaultValue
ElseIf SESSION.HasUnoProperty(poColumn, "ControlDefault") Then ' Default value set in Base via table edition
If IsEmpty(.ControlDefault) Then sValue = "" Else sValue = .ControlDefault
Else
sValue = ""
End If
' Convert the string to a native type
If sValue = "" Then ' No default value => Null or Empty
If .IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then vValue = Null Else vValue = Empty
Else
vValue = sValue
With com.sun.star.sdbc.DataType
Select Case poColumn.Type
Case .CHAR, .VARCHAR, .LONGVARCHAR
Case .BIT, .BOOLEAN : vValue = CBool( sValue = "1" )
Case .TINYINT : vValue = CInt(sValue)
Case .SMALLINT, .INTEGER, .BIGINT : vValue = CLng(sValue)
Case .FLOAT : vValue = CSng(sValue)
Case .REAL, .DOUBLE : vValue = CDbl(sValue)
Case .NUMERIC, .DECIMAL
If SESSION.HasUnoProperty(poColumn, "Scale") Then
If poColumn.Scale > 0 Then vValue = CDbl(sValue)
End If
Case .DATE : vValue = DateValue(sValue)
Case .TIME : vValue = TimeValue(sValue)
Case .TIMESTAMP : vValue = DateValue(sValue) + TimeValue(sValue)
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
Case .CLOB
Case Else
End Select
End With
End If
End With
Finally:
_ConvertDefaultValue = vValue
Exit Function
End Function ' SFDatabases.SF_Dataset._ConvertDefaultValue
REM -----------------------------------------------------------------------------
Public Function _Initialize() As Boolean
''' Called immediately after instance creation to complete the initial values
''' An eventual error must be trapped in the calling routine to cancel the instance creation
''' Returns:
''' False when Dataset creation is unsuccessful. Typically because of SQL error
Dim bDataset As Boolean ' Return value
Dim bErrorHandler As Boolean ' Can be set off to ease debugging of complex SQL statements
Dim sFields As String ' Comma-separated list of field names
Dim sUpdatableFields As String ' Comma-separated list of updatable field names
Dim oColumn As Object ' com.sun.star.sdb.ODataColumn
Dim SESSION As Object : Set SESSION = ScriptForge.SF_Services.CreateScriptService("ScriptForge.Session")
Dim i As Long
bErrorHandler = ScriptForge.SF_Utils._ErrorHandling()
If bErrorHandler Then On Local Error GoTo Catch
Try:
Set _RowSet = CreateUnoService("com.sun.star.sdb.RowSet")
With _RowSet
Set .ActiveConnection = _ParentDatabase._Connection
.Command = _Sql
Select Case _DatasetType
Case "TABLE" : .CommandType = com.sun.star.sdb.CommandType.TABLE
Case "QUERY" : .CommandType = com.sun.star.sdb.CommandType.QUERY
Case "SQL" : .CommandType = com.sun.star.sdb.CommandType.COMMAND
End Select
.EscapeProcessing = Not _DirectSql
.Filter = _Filter
.ApplyFilter = ( Len(_Filter) > 0 )
.order = _OrderBy
If _ReadOnly Then
.TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_UNCOMMITTED
Else
.TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_COMMITTED
End If
If bErrorHandler Then On Local Error GoTo CatchSql
.execute()
If bErrorHandler Then On Local Error GoTo Catch
' Collect info about columns: field name, updatable, default value, AutoValue
With .Columns
sFields = ""
sUpdatableFields = ""
ReDim _DefaultValues (0 To .Count - 1)
' Columns are scanned by index to guarantee that names and indexes are aligned
For i = 0 To .Count - 1
Set oColumn = .getByIndex(i)
With oColumn
' Field names
sFields = sFields & "," & .Name
' Updatable field names
If Not _ReadOnly And .IsWritable And Not .IsAutoIncrement Then sUpdatableFields = sUpdatableFields & "," & .Name
' Default values
_DefaultValues(i) = _ConvertDefaultValue(oColumn)
' AutoValue
If _AutoValue < 0 And .IsAutoIncrement Then _AutoValue = i
End With
Next i
If Len(sFields) <= 1 Then _Fields = Array() Else _Fields = Split(Mid(sFields, 2), ",")
If Len(sUpdatableFields) <= 1 Then _UpdatableFields = Array() Else _UpdatableFields = Split(Mid(sUpdatableFields, 2), ",")
End With
End With
' Insert the instance in the _Datasets array of the parent database
_DatasetIndex = _ParentDatabase._AddToDatasets([Me])
bDataset = ( _DatasetIndex >= 0 )
Finally:
_Initialize = bDataset
Exit Function
Catch:
bDataset = False
GoTo Finally
CatchSql:
On Local Error GoTo 0
ScriptForge.SF_Exception.RaiseFatal(SQLSYNTAX2ERROR, _Sql, "WHERE " & _Filter, "ORDER BY " & _OrderBy)
GoTo Catch
End Function ' SFDatabases.SF_Dataset._Initialize
REM -----------------------------------------------------------------------------
Private Function _PropertyGet(Optional ByVal psProperty As String) As Variant
''' Return the value of the named property
''' Args:
''' psProperty: the name of the property
Dim vBookmark As Variant ' Bookmark on the current record
Dim vValue As Variant ' A single record field value
Dim vValuesDict As Object ' A dictionary (field name, field value)
Dim i As Long
Dim cstThisSub As String
Const cstSubArgs = ""
cstThisSub = "SFDatabases.Dataset.get" & psProperty
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
With _RowSet
Select Case psProperty
Case "BOF"
_PropertyGet = .isBeforeFirst()
Case "DefaultValues"
' Load the pairs field name / field default value in the dictionary
vValuesDict = ScriptForge.SF_Services.CreateScriptService("ScriptForge.Dictionary")
For i = 0 To UBound(_DefaultValues)
vValuesDict.Add(_Fields(i), _DefaultValues(i))
Next i
Set _PropertyGet = vValuesDict
Case "EOF"
_PropertyGet = .isAfterLast()
Case "Fields"
_PropertyGet = _Fields
Case "Filter"
_PropertyGet = _Filter
Case "OrderBy"
_PropertyGet = _OrderBy
Case "ParentDatabase"
Set _PropertyGet = _ParentDatabase
Case "RowCount"
If .IsRowCountFinal Then
_PropertyGet = .RowCount
Else
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then vBookmark = Null Else vBookmark = .getBookmark
.last()
_PropertyGet = .RowCount
If IsNull(vBookmark) Then .beforeFirst() Else .moveToBookmark(vBookmark)
End If
Case "RowNumber"
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then _PropertyGet = 0 Else _PropertyGet = .Row
Case "Source"
_PropertyGet = _Command
Case "SourceType"
_PropertyGet = _DatasetType
Case "UpdatableFields"
_PropertyGet = _UpdatableFields
Case "Values"
If .isBeforeFirst() Or .isAfterLast() Or .rowDeleted() Then
Set _PropertyGet = Nothing
Else
' Load the pairs field name / field value in the dictionary
vValuesDict = ScriptForge.SF_Services.CreateScriptService("ScriptForge.Dictionary")
For i = 0 To UBound(_Fields)
vValue = _ParentDatabase._GetColumnValue(_RowSet, i + 1, False)
vValuesDict.Add(_Fields(i), vValue)
Next i
Set _PropertyGet = vValuesDict
End If
Case "XRowSet"
Set _PropertyGet = _RowSet
Case Else
_PropertyGet = Null
End Select
End With
Finally:
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset._PropertyGet
REM -----------------------------------------------------------------------------
Private Function _PropertySet(Optional ByVal psProperty As String _
, Optional ByVal pvValue As Variant _
) As Boolean
''' Set the new value of the named property
''' Args:
''' psProperty: the name of the property
''' pvValue: the new value of the given property
''' Returns:
''' True if successful
Dim bSet As Boolean ' Return value
Dim cstThisSub As String
Const cstSubArgs = "Value"
If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
bSet = False
cstThisSub = "SFDatabases.Dataset.set" & psProperty
ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
bSet = True
Select Case UCase(psProperty)
Case UCase("BOF")
If Not ScriptForge.SF_Utils._Validate(pvValue, "BOF", ScriptForge.V_BOOLEAN) Then GoTo Finally
If pvValue Then _RowSet.beforeFirst() ' Only True is valid
Case UCase("EOF")
If Not ScriptForge.SF_Utils._Validate(pvValue, "EOF", ScriptForge.V_BOOLEAN) Then GoTo Finally
If pvValue Then _RowSet.afterLast() ' Only True is valid
Case Else
bSet = False
End Select
Finally:
_PropertySet = bSet
ScriptForge.SF_Utils._ExitFunction(cstThisSub)
Exit Function
Catch:
GoTo Finally
End Function ' SFDatabases.SF_Dataset._PropertySet
REM -----------------------------------------------------------------------------
Private Function _Repr() As String
''' Convert the Dataset instance to a readable string, typically for debugging purposes (DebugPrint ...)
''' Args:
''' Return:
''' "[DATASET]: tablename,base file url"
_Repr = "[DATASET]: " & _Command & "," & _ParentDatabase._Location
End Function ' SFDatabases.SF_Dataset._Repr
REM -----------------------------------------------------------------------------
Private Function _SetColumnValue(ByVal plColIndex As Long _
, ByRef pvValue As Variant _
) As Boolean
''' Store a value in a given column of the current record
''' The resultset.insertRow() or resultset.updateRow() methods are supposed to be executed in the calling routine
''' The type of the column is found in the resultset's metadata
''' Args:
''' plColIndex: the index of the column to extract the value from. Starts at 0
''' Read-only columns are ignored.
''' pvValue:the Variant value to store in the column
''' Strings and numbers are supplied respectively as strings or numeric values
''' Dates and times are supplied as Basic dates
''' Null values are supplied as Null
''' Errors or other strange data types are ignored
''' Returns:
''' True when successful
''' Exceptions:
''' RECORDUPDATEERROR when value to store does not fit the type of the field
''' or when field is not nullable and value = Null
''' or when field is not writable or is an autovalue
''' or when input file does not exist or is empty
''' or when field type is not supported
Dim bSet As Boolean ' Return value
Dim sColumn As String ' Column name
Dim oColumn As Object ' com.sun.star.sdb.DataColumn
Dim lType As Long ' SQL column type: com.sun.star.sdbc.DataType
Dim vDateTime As Variant ' com.sun.star.util.DateTime
Dim bNullable As Boolean ' The field is defined as accepting Null values
Dim vTemp As Variant ' Work variable for date and time related conversions
Dim sFile As String ' File name in FileSystem notation
Dim oSimpleFileAccess As Object ' com.sun.star.ucb.SimpleFileAccess
Dim oStream As Object ' com.sun.star.io.XInputStream
Dim lFileLength As Long ' Binary file length in bytes
Dim UTILS As Object : Set UTILS = ScriptForge.SF_Utils
Dim SESS As Object : Set SESS = ScriptForge.SF_Session
bSet = False
On Local Error GoTo CatchError
Check:
Set oColumn = _RowSet.Columns.getByIndex(plColIndex)
sColumn = oColumn.Name
If _ReadOnly Then GoTo CatchError
If Not ScriptForge.SF_Array.Contains(_UpdatableFields, sColumn, CaseSensitive := True) Then GoTo CatchError
Try:
With com.sun.star.sdbc.DataType
If IsEmpty(pvValue) Then ' An empty default value means not nullable and no default => ignore
ElseIf IsNull(pvValue) Then
If oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then oColumn.updateNull() Else Goto CatchError
Else
Select Case oColumn.Type
Case .BIT, .BOOLEAN
If VarType(pvValue) <> UTILS.V_BOOLEAN Then GoTo CatchError
oColumn.updateBoolean(pvValue)
Case .TINYINT
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
If pvValue < -128 Or pvValue > +127 Then Goto CatchError
oColumn.updateShort(CInt(pvValue))
Case .SMALLINT
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
If pvValue < -32768 Or pvValue > 32767 Then Goto CatchError
oColumn.updateInt(CInt(pvValue))
Case .INTEGER
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
If pvValue < -2147483648 Or pvValue > 2147483647 Then Goto CatchError
oColumn.updateInt(CLng(pvValue))
Case .BIGINT
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
oColumn.updateLong(pvValue) ' No proper type conversion for HYPER data type
Case .FLOAT
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
If Abs(pvValue) < 3.402823E38 And Abs(pvValue) > 1.401298E-45 Then oColumn.updateFloat(CSng(pvValue)) Else Goto CatchError
Case .REAL, .DOUBLE
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then oColumn.updateDouble(CDbl(pvValue)) Else Goto CatchError
oColumn.updateDouble(CDbl(pvValue))
Case .NUMERIC, .DECIMAL
If UTILS._VarTypeExt(pvValue) <> UTILS.V_NUMERIC Then Goto CatchError
If SESS.HasUnoProperty(oColumn, "Scale") Then
If oColumn.Scale > 0 Then
'If Abs(pvValue) < 1.79769313486232E308 And Abs(pvValue) > 4.94065645841247E-307 Then oColumn.updateDouble(CDbl(pvValue)) Else Goto CatchError
oColumn.updateDouble(CDbl(pvValue))
Else
oColumn.updateString(CStr(pvValue))
End If
Else
Column.updateString(CStr(pvValue))
End If
Case .CHAR, .VARCHAR, .LONGVARCHAR, .CLOB
If VarType(pvValue) <> V_STRING Then GoTo CatchError
If SESS.HasUnoProperty(oColumn, "Precision") Then
If oColumn.Precision > 0 And Len(pvValue) > oColumn.Precision Then Goto CatchError
End If
oColumn.updateString(pvValue)
Case .DATE
If VarType(pvValue) <> V_DATE Then GoTo CatchError
vTemp = New com.sun.star.util.Date
With vTemp
.Day = Day(pvValue)
.Month = Month(pvValue)
.Year = Year(pvValue)
End With
oColumn.updateDate(vTemp)
Case .TIME
If VarType(pvValue) <> V_DATE Then GoTo CatchError
vTemp = New com.sun.star.util.Time
With vTemp
.Hours = Hour(pvValue)
.Minutes = Minute(pvValue)
.Seconds = Second(pvValue)
.NanoSeconds = 0
End With
oColumn.updateTime(vTemp)
Case .TIMESTAMP
If VarType(pvValue) <> V_DATE Then GoTo CatchError
vTemp = New com.sun.star.util.DaWHEREteTime
With vTemp
.Day = Day(pvValue)
.Month = Month(pvValue)
.Year = Year(pvValue)
.Hours = Hour(pvValue)
.Minutes = Minute(pvValue)
.Seconds = Second(pvValue)
.NanoSeconds = 0
End With
oColumn.updateTimestamp(vTemp)
Case .BINARY, .VARBINARY, .LONGVARBINARY, .BLOB
If VarType(pvValue) <> V_STRING Then GoTo CatchError
If Not UTILS._ValidateFile(pvValue, "FieldValue") Then GoTo CatchError
' Verify file
sFile = ConvertToUrl(pvValue)
oSimpleFileAccess = UTILS._GetUnoService("FileAccess")
If Not oSimpleFileAccess.exists(sFile) Then Goto CatchError
' Load the binary data
Set oStream = oSimpleFileAccess.openFileRead(sFile)
lFileLength = oStream.getLength()
If lFileLength = 0 Then Goto CatchError ' <<<<<<<<<<<<<<<<< PUT NULL
oColumn.updateBinaryStream(oStream, lFileLength)
oStream.closeInput()
Case Else
Goto CatchError
End Select
End If
End With
bSet = True
Finally:
_SetColumnValue = bSet
Exit Function
CatchError:
On Local Error GoTo 0
ScriptForge.SF_Exception.RaiseFatal(RECORDUPDATEERROR, sColumn, ScriptForge.SF_String.Represent(pvValue), oColumn.TypeName)
GoTo Finally
End Function ' SFDatabases.SF_Dataset._SetColumnValue
REM ============================================ END OF SFDATABASES.SF_DATASET
</script:module>
Mini Shell