diff options
Diffstat (limited to 'wizards/source/sfdatabases/SF_Dataset.xba')
| -rw-r--r-- | wizards/source/sfdatabases/SF_Dataset.xba | 1672 |
1 files changed, 1672 insertions, 0 deletions
diff --git a/wizards/source/sfdatabases/SF_Dataset.xba b/wizards/source/sfdatabases/SF_Dataset.xba new file mode 100644 index 0000000000..02b3d35aff --- /dev/null +++ b/wizards/source/sfdatabases/SF_Dataset.xba @@ -0,0 +1,1672 @@ +<?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>
\ No newline at end of file |