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