REM ======================================================================================================================= REM === The Access2Base library is a part of the LibreOffice project. === REM === Full documentation is available on http://www.access2base.com === REM ======================================================================================================================= Option Compatible Option ClassModule Option Explicit REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS ROOT FIELDS --- REM ----------------------------------------------------------------------------------------------------------------------- Private _Type As String ' Must be RECORDSET Private _This As Object ' Workaround for absence of This builtin function Private _Parent As Object Private _Name As String ' Unique, generated Private _Fields() As Variant Private _ParentName As String Private _ParentType As String Private _ParentDatabase As Object Private _ForwardOnly As Boolean Private _PassThrough As Boolean Private _ReadOnly As Boolean Private _CommandType As Long Private _Command As String Private _DataSet As Boolean ' True if execute() successful Private _BOF As Boolean Private _EOF As Boolean Private _Filter As String Private _EditMode As Integer ' dbEditxxx constants Private _BookmarkBeforeNew As Variant Private _BookmarkLastModified As Variant Private _IsClone As Boolean Private _ManageChunks As Variant ' Array of ChunkDescriptors Private RowSet As Object ' com.sun.star.comp.dba.ORowSet Type ChunkDescriptor ChunksRequested As Boolean FieldName As String ChunkType As Integer ' vbString or vbByte FileName As String FileHandler As Object End Type REM ----------------------------------------------------------------------------------------------------------------------- REM --- CONSTRUCTORS / DESTRUCTORS --- REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Initialize() _Type = OBJRECORDSET Set _This = Nothing Set _Parent = Nothing _Name = "" _Fields = Array() _ParentName = "" Set _ParentDatabase = Nothing _ParentType = "" _ForwardOnly = False _PassThrough = False _ReadOnly = False _CommandType = 0 _Command = "" _DataSet = False _BOF = True _EOF = True _Filter = "" _EditMode = dbEditNone _BookmarkBeforeNew = Null _BookmarkLastModified = Null _IsClone = False Set _ManageChunks = Array() Set RowSet = Nothing End Sub ' Constructor REM ----------------------------------------------------------------------------------------------------------------------- Private Sub Class_Terminate() On Local Error Resume Next mClose() End Sub REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS GET/LET/SET PROPERTIES --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Property Get AbsolutePosition() As Variant AbsolutePosition = _PropertyGet("AbsolutePosition") End Property ' AbsolutePosition (get) Property Let AbsolutePosition(ByVal pvValue As Variant) Call _PropertySet("AbsolutePosition", pvValue) End Property ' AbsolutePosition (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get BOF() As Boolean BOF = _PropertyGet("BOF") End Property ' BOF (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Bookmark() As Variant Bookmark = _PropertyGet("Bookmark") End Property ' Bookmark (get) Property Let Bookmark(ByVal pvValue As Variant) Call _PropertySet("Bookmark", pvValue) End Property ' Bookmark (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Bookmarkable() As Boolean Bookmarkable = _PropertyGet("Bookmarkable") End Property ' Bookmarkable (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get EOF() As Boolean EOF = _PropertyGet("EOF") End Property ' EOF (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get EditMode() As Integer EditMode = _PropertyGet("EditMode") End Property ' EditMode (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Filter() As Variant Filter = _PropertyGet("Filter") End Property ' Filter (get) Property Let Filter(ByVal pvValue As Variant) Call _PropertySet("Filter", pvValue) End Property ' Filter (set) REM ----------------------------------------------------------------------------------------------------------------------- Property Get LastModified() As Variant ' DO NOT PUBLISH LastModified = _PropertyGet("LastModified") End Property ' LastModified (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get Name() As String Name = _PropertyGet("Name") End Property ' Name (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get ObjectType() As String ObjectType = _PropertyGet("ObjectType") End Property ' ObjectType (get) REM ----------------------------------------------------------------------------------------------------------------------- Property Get RecordCount() As Long RecordCount = _PropertyGet("RecordCount") End Property ' RecordCount (get) REM ----------------------------------------------------------------------------------------------------------------------- REM --- CLASS METHODS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function AddNew() As Boolean ' Initiates the creation of a new record Const cstThisSub = "Recordset.AddNew" Dim i As Integer, iFieldsCount As Integer, oField As Object Dim sDefault As String, oColumn As Object Dim iValue As Integer, lValue As Long, sgValue As Single, dbValue As Double, dValue As Date Dim vTemp As Variant If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) AddNew = False With RowSet 'Is inserting a new row allowed ? If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate If Not .CanUpdateInsertedRows Then Goto Error_NoUpdate If Not .IsBookmarkable Then Goto Error_NoUpdate If _EditMode <> dbEditNone Then CancelUpdate() If _BOF And _EOF Then ' Records before first or after last do not have a bookmark _BookmarkBeforeNew = "_BOF_" ElseIf .isBeforeFirst() Then _BookmarkBeforeNew = "_BOF_" ElseIf .isAfterLast() Then _BookmarkBeforeNew = "_EOF_" Else _BookmarkBeforeNew = .getBookmark() End If .moveToInsertRow() 'Set all fields to their default value iFieldsCount = Fields().Count On Local Error Resume Next ' Do not stop if default setting fails For i = 0 To iFieldsCount - 1 Set oField = Fields(i) Set oColumn = oField.Column sDefault = oField.DefaultValue If sDefault = "" Then ' No default value If oColumn.IsNullable = com.sun.star.sdbc.ColumnValue.NULLABLE Then oColumn.updateNull() Else With com.sun.star.sdbc.DataType Select Case oColumn.Type Case .BIT, .BOOLEAN If sDefault = "1" Then oColumn.updateBoolean(True) Else oColumn.updateBoolean(False) Case .TINYINT iValue = CInt(sDefault) If iValue >= -128 And iValue <= +127 Then oColumn.updateShort(iValue) Case .SMALLINT lValue = CLng(sDefault) If lValue >= -32768 And lValue <= 32767 Then oColumn.updateInt(lValue) Case .INTEGER lValue = CLng(sDefault) If lValue >= -2147483648 And lValue <= 2147483647 Then oColumn.updateInt(lValue) Case .BIGINT lValue = CLng(sDefault) Column.updateLong(lValue) ' No proper type conversion for HYPER data type Case .FLOAT sgValue = CSng(sDefault) If Abs(sgValue) < 3.402823E38 And Abs(sgValue) > 1.401298E-45 Then oColumn.updateFloat(sgValue) Case .REAL, .DOUBLE dbValue = CDbl(sDefault) 'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue) oColumn.updateDouble(dbValue) Case .NUMERIC, .DECIMAL dbValue = CDbl(sDefault) If Utils._hasUNOProperty(Column, "Scale") Then If Column.Scale > 0 Then 'If Abs(dbValue) < 1.79769313486232E308 And Abs(dbValue) > 4.94065645841247E-307 Then oColumn.updateDouble(dbValue) oColumn.updateDouble(dbValue) Else oColumn.updateString(sDefault) End If Else oColumn.updateString(sDefault) End If Case .CHAR, .VARCHAR, .LONGVARCHAR oColumn.updateString(sDefault) ' vbString Case .DATE dValue = DateValue(sDefault) vTemp = New com.sun.star.util.Date With vTemp .Day = Day(dValue) .Month = Month(dValue) .Year = Year(dValue) End With oColumn.updateDate(vTemp) Case .TIME dValue = TimeValue(sDefault) vTemp = New com.sun.star.util.Time With vTemp .Hours = Hour(dValue) .Minutes = Minute(dValue) .Seconds = Second(dValue) '.HundredthSeconds = 0 End With oColumn.updateTime(vTemp) Case .TIMESTAMP dValue = DateValue(sDefault) vTemp = New com.sun.star.util.DateTime With vTemp .Day = Day(dValue) .Month = Month(dValue) .Year = Year(dValue) .Hours = Hour(dValue) .Minutes = Minute(dValue) .Seconds = Second(dValue) '.HundredthSeconds = 0 End With oColumn.updateTimestamp(vTemp) ' Case .BINARY, .VARBINARY, .LONGVARBINARY ' Case .BLOB ' Case .CLOB Case Else End Select End With End If Next i End With If _ErrorHandler() Then On Local Error Goto Error_Function Else On Local Error Goto 0 _EditMode = dbEditAdd AddNew = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_NoUpdate: TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function End Function ' AddNew REM ----------------------------------------------------------------------------------------------------------------------- Public Function CancelUpdate() As Boolean ' Cancel any edit action Const cstThisSub = "Recordset.CancelUpdate" If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) CancelUpdate = False With RowSet Select Case _EditMode Case dbEditNone Case dbEditAdd _AppendChunkClose(True) If Not IsNull(_BookmarkBeforeNew) Then Select Case _BookmarkBeforeNew Case "_BOF_" : .beforeFirst() Case "_EOF_" : .afterLast() Case Else : .moveToBookmark(_BookmarkBeforeNew) End Select End If Case dbEditInProgress .cancelRowUpdates() _AppendChunkClose(True) End Select End With _EditMode = dbEditNone _BookmarkBeforeNew = Null _BookmarkLastModified = Null CancelUpdate = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function End Function ' CancelUpdate REM ----------------------------------------------------------------------------------------------------------------------- Public Function Clone() As Object ' Duplicate an existing recordset Const cstThisSub = "Recordset.Clone" Const cstNull = -1 Dim iType As Integer, iOptions As Integer, iLockEdit As Integer If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) Set Clone = Nothing If _IsClone Then Goto Error_Clone If _ForwardOnly Then iType = dbOpenForwardOnly Else iType = cstNull If _PassThrough Then iOptions = dbSQLPassThrough Else iOptions = cstNull iLockEdit = dbReadOnly ' Always read-only Set Clone = OpenRecordset(iType, iOptions, iLockEdit, True) Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_Clone: TraceError(TRACEFATAL, ERRRECORDSETCLONE, Utils._CalledSub(), 0) Goto Exit_Function End Function ' Clone REM ----------------------------------------------------------------------------------------------------------------------- Public Function mClose(ByVal Optional pbRemove As Boolean) As Variant ' Dispose UNO objects ' If pbRemove = True, remove recordset from Recordsets collection Const cstThisSub = "Recordset.Close" Dim i As Integer If _ErrorHandler() Then On Local Error Goto Exit_Function ' Do not stop execution Utils._SetCalledSub(cstThisSub) If Not IsNull(RowSet) Then RowSet.close() RowSet.dispose() End If _ForwardOnly = False _PassThrough = False _ReadOnly = False _CommandType = 0 _Command = "" _ParentName = "" _ParentType = "" _DataSet = False _BOF = True _EOF = True _Filter = "" _EditMode = dbEditNone _BookmarkBeforeNew = Null _BookmarkLastModified = Null _IsClone = False For i = 0 To UBound(_Fields) If Not IsNull(_Fields(i)) Then _Fields(i).Dispose() Set _Fields(i) = Nothing End If Next i _Fields = Array() Set RowSet = Nothing If IsMissing(pbRemove) Then pbRemove = True If pbRemove Then _ParentDatabase.RecordsetsColl.Remove(_Name) Set _ParentDatabase = Nothing Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' Close REM ----------------------------------------------------------------------------------------------------------------------- Public Function Delete() As Boolean ' Deletes the current record Const cstThisSub = "Recordset.Delete" If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) Delete = False 'Is deleting a row allowed ? If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate If _EditMode <> dbEditNone Then CancelUpdate() Goto Error_Sequence End If If RowSet.rowDeleted() Then Goto Error_RowDeleted RowSet.deleteRow() Delete = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_NoUpdate: TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function Error_RowDeleted: TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) Goto Exit_Function Error_Sequence: TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) Goto Exit_Function End Function ' Delete REM ----------------------------------------------------------------------------------------------------------------------- Public Function Edit() As Boolean ' Updates the current record Const cstThisSub = "Recordset.Edit" If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) Edit = False 'Is updating a row allowed ? If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate If _EditMode <> dbEditNone Then CancelUpdate() If RowSet.rowDeleted() Then Goto Error_RowDeleted _EditMode = dbEditInProgress Edit = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_NoUpdate: TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function Error_RowDeleted: TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) Goto Exit_Function End Function ' Edit REM ----------------------------------------------------------------------------------------------------------------------- Public Function Fields(ByVal Optional pvIndex As variant) As Object If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "Recordset.Fields" Utils._SetCalledSub(cstThisSub) Set Fields = Nothing If Not IsMissing(pvIndex) Then If Not Utils._CheckArgument(pvIndex, 1, Utils._AddNumeric(vbString)) Then Goto Exit_Function End If Dim sObjects() As String, sObjectName As String, oObject As Object Dim i As Integer, oFields As Object, iIndex As Integer ' No argument, return a collection If IsMissing(pvIndex) Then Set oObject = New Collect Set oObject._This = oObject oObject._CollType = COLLFIELDS Set oObject._Parent = _This oObject._Count = RowSet.getColumns().Count Goto Exit_Function End If Set oFields = RowSet.getColumns() sObjects = oFields.ElementNames() ' Argument is the field name If VarType(pvIndex) = vbString Then iIndex = -1 ' Check existence of object and find its exact (case-sensitive) name For i = 0 To UBound(sObjects) If UCase(pvIndex) = UCase(sObjects(i)) Then sObjectName = sObjects(i) iIndex = i Exit For End If Next i If iIndex < 0 Then Goto Trace_NotFound ' Argument is numeric Else If pvIndex < 0 Or pvIndex > UBound(sObjects) Then Goto Trace_IndexError sObjectName = sObjects(pvIndex) iIndex = pvIndex End If ' Check if field object already buffered in _Fields() array If UBound(_Fields) < 0 Then ' Initialize _Fields ReDim _Fields(0 To UBound(sObjects)) For i = 0 To UBound(sObjects) Set _Fields(i) = Nothing Next i End If If Not IsNull(_Fields(iIndex)) Then Set oObject = _Fields(iIndex) ' Otherwise create new field object Else Set oObject = New Field Set oObject._This = oObject oObject._Name = sObjectName Set oObject.Column = oFields.getByName(sObjectName) If Utils._hasUNOProperty(oObject.Column, "Precision") Then oObject._Precision = oObject.Column.Precision oObject._ParentName = _Name oObject._ParentType = _Type Set oObject._ParentDatabase = _ParentDatabase Set oObject._ParentRecordset = _This Set _Fields(iIndex) = oObject End If Exit_Function: Set Fields = oObject Set oObject = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_NotFound: TraceError(TRACEFATAL, ERROBJECTNOTFOUND, Utils._CalledSub(), 0, , Array(_GetLabel("FIELD"), pvIndex)) Goto Exit_Function Trace_IndexError: TraceError(TRACEFATAL, ERRCOLLECTION, Utils._CalledSub(), 0) Goto Exit_Function End Function ' Fields REM ----------------------------------------------------------------------------------------------------------------------- Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant ' Return property value of psProperty property name Const cstThisSub = "Recordset.getProperty" Utils._SetCalledSub(cstThisSub) If IsMissing(pvProperty) Then Call _TraceArguments() getProperty = _PropertyGet(pvProperty) Utils._ResetCalledSub(cstThisSub) End Function ' getProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function GetRows(ByVal Optional pvNumRows As variant, ByVal Optional pbStrDate As Boolean) As Variant ' UNPUBLISHED - pbStrDate = True forces all dates to be converted into strings If _ErrorHandler() Then On Local Error Goto Error_Function Const cstThisSub = "Recordset.GetRows" Utils._SetCalledSub(cstThisSub) If IsMissing(pbStrDate) Then pbStrDate = False Dim vMatrix() As Variant, lSize As Long, iNumFields As Integer, i As Integer vMatrix() = Array() If IsMissing(pvNumRows) Then Call _TraceArguments() If Not Utils._CheckArgument(pvNumRows, 1, Utils._AddNumeric()) Then Goto Exit_Function If pvNumRows < 1 Then Goto Trace_Error If IsNull(RowSet) Then Goto Trace_Closed If Not _DataSet Then Goto Exit_Function If _EditMode <> dbEditNone Then CancelUpdate() If _EOF Then Goto Exit_Function lSize = -1 iNumFields = RowSet.getColumns().Count - 1 If iNumFields < 0 Then Goto Exit_Function ReDim vMatrix(0 To iNumFields, 0 To pvNumRows - 1) Do While Not _EOF And lSize < pvNumRows - 1 lSize = lSize + 1 For i = 0 To iNumFields vMatrix(i, lSize) = Utils._getResultSetColumnValue(RowSet, i + 1) If pbStrDate And IsDate(vMatrix(i, lSize)) Then vMatrix(i, lSize) = _CStr(vMatrix(i, lSize)) Next i _Move("NEXT") Loop If lSize < pvNumRows - 1 Then ' Resize to number of fetched records ReDim Preserve vMatrix(0 To iNumFields, 0 To lSize) End If Exit_Function: GetRows() = vMatrix() Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Trace_Error: TraceError(TRACEFATAL, ERRWRONGARGUMENT, Utils._CalledSub(), 0, , Array(1, pvNumRows)) Set Controls = Nothing Goto Exit_Function Trace_Closed: TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) Goto Exit_Function End Function ' GetRows V1.1.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean ' Return True if object has a valid property called pvProperty (case-insensitive comparison !) Const cstThisSub = "Recordset.hasProperty" Utils._SetCalledSub(cstThisSub) If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty) Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' hasProperty REM ----------------------------------------------------------------------------------------------------------------------- Public Function Move(ByVal Optional pvRelative As Variant, ByVal Optional pvBookmark As variant) As Boolean ' Move record pointer Relative rows vs. bookmark or current record If IsMissing(pvRelative) Then Call _TraceArguments() If Not Utils._CheckArgument(pvRelative, 1, Utils._AddNumeric()) Then Goto Exit_Function If IsMissing(pvBookmark) Then Move = _Move(pvRelative) Else Move = _Move(pvRelative, pvBookmark) Exit_Function: Exit Function End Function ' Move REM ----------------------------------------------------------------------------------------------------------------------- Public Function MoveFirst() As Boolean MoveFirst = _Move("First") End Function ' MoveFirst REM ----------------------------------------------------------------------------------------------------------------------- Public Function MoveLast() As Boolean MoveLast = _Move("Last") End Function ' MoveLast REM ----------------------------------------------------------------------------------------------------------------------- Public Function MoveNext() As Boolean MoveNext = _Move("Next") End Function ' MoveNext REM ----------------------------------------------------------------------------------------------------------------------- Public Function MovePrevious() As Boolean MovePrevious = _Move("Previous") End Function ' MovePrevious REM ----------------------------------------------------------------------------------------------------------------------- Public Function OpenRecordset(ByVal Optional pvType As Variant _ , ByVal Optional pvOptions As Variant _ , ByVal Optional pvLockEdit As Variant _ , ByVal Optional pbClone As Boolean) As Object 'Return a Recordset object based on current recordset object with filter addition If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = Utils._PCase(_Type) & ".OpenRecordset" Utils._SetCalledSub(cstThisSub) Set OpenRecordset = Nothing Const cstNull = -1 Dim oObject As Object Set oObject = Nothing If IsMissing(pvType) Then pvType = cstNull Else If Not Utils._CheckArgument(pvType, 1, Utils._AddNumeric(), Array(cstNull, dbOpenForwardOnly)) Then Goto Exit_Function End If If IsMissing(pvOptions) Then pvOptions = cstNull Else If Not Utils._CheckArgument(pvOptions, 2, Utils._AddNumeric(), Array(cstNull, dbSQLPassThrough)) Then Goto Exit_Function End If If IsMissing(pvLockEdit) Then pvLockEdit = cstNull Else If Not Utils._CheckArgument(pvLockEdit, 3, Utils._AddNumeric(), Array(cstNull, dbReadOnly)) Then Goto Exit_Function End If If IsMissing(pbClone) Then pbClone = False ' pbClone is a not published argument Set oObject = New Recordset With oObject ._CommandType = _CommandType ._Command = _Command ._ParentName = _Name ._ParentType = _Type Set ._ParentDatabase = _ParentDatabase Set ._This = oObject ._ForwardOnly = ( pvType = dbOpenForwardOnly ) ._PassThrough = ( pvOptions = dbSQLPassThrough ) ._ReadOnly = ( (pvLockEdit = dbReadOnly) Or _ReadOnly ) Select Case True Case pbClone : Call ._Initialize(, RowSet) Case _Filter <> "" : Call ._Initialize(_Filter) Case Else : Call ._Initialize() End Select End With With _ParentDatabase .RecordsetMax = .RecordsetMax + 1 oObject._Name = Format(.RecordsetMax, "0000000") .RecordsetsColl.Add(oObject, UCase(oObject._Name)) End With If Not ( oObject._BOF And oObject._EOF ) Then oObject.MoveFirst() ' Do nothing if resultset empty Exit_Function: Set OpenRecordset = oObject Set oObject = Nothing Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) GoTo Exit_Function End Function ' OpenRecordset REM ----------------------------------------------------------------------------------------------------------------------- Public Function Properties(ByVal Optional pvIndex As Variant) As Variant ' Return ' a Collection object if pvIndex absent ' a Property object otherwise Const cstThisSub = "Recordset.Properties" Utils._SetCalledSub(cstThisSub) Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String vPropertiesList = _PropertiesList() sObject = Utils._PCase(_Type) If IsMissing(pvIndex) Then vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList) Else vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex) vProperty._Value = _PropertyGet(vPropertiesList(pvIndex)) End If Set vProperty._ParentDatabase = _ParentDatabase Exit_Function: Set Properties = vProperty Utils._ResetCalledSub(cstThisSub) Exit Function End Function ' Properties REM ----------------------------------------------------------------------------------------------------------------------- Public Function setProperty(ByVal Optional psProperty As String, ByVal Optional pvValue As Variant) As Boolean ' Return True if property setting OK Const cstThisSub = "Recordset.setProperty" Utils._SetCalledSub(cstThisSub) setProperty = _PropertySet(psProperty, pvValue) Utils._ResetCalledSub(cstThisSub) End Function REM ----------------------------------------------------------------------------------------------------------------------- Public Function Update() As Boolean ' Finalize the updates of the current record Const cstThisSub = "Recordset.Update" If _ErrorHandler() Then On Local Error Goto Error_Function Utils._SetCalledSub(cstThisSub) Update = False 'Is updating a row allowed ? If _ForwardOnly Or _ReadOnly Then Goto Error_NoUpdate With RowSet If .rowDeleted() Then Goto Error_RowDeleted Select Case _EditMode Case dbEditNone Goto Trace_Error_Update Case dbEditAdd _AppendChunkClose(False) If .IsNew And .IsModified Then .insertRow() _BookmarkLastModified = .getBookmark() If Not IsNull(_BookmarkBeforeNew) Then Select Case _BookmarkBeforeNew Case "_BOF_" : .beforeFirst() Case "_EOF_" : .afterLast() Case Else : .moveToBookmark(_BookmarkBeforeNew) End Select End If Case dbEditInProgress _AppendChunkClose(False) If .IsModified Then .updateRow() _BookmarkLastModified = .getBookmark() End If End Select End With _EditMode = dbEditNone Update = True Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Function Error_NoUpdate: TraceError(TRACEFATAL, ERRNOTUPDATABLE, Utils._CalledSub(), 0) Goto Exit_Function Trace_Error_Update: TraceError(TRACEFATAL, ERRUPDATESEQUENCE, Utils._CalledSub(), 0, 1) Goto Exit_Function Error_RowDeleted: TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) Goto Exit_Function End Function ' Update REM ----------------------------------------------------------------------------------------------------------------------- REM --- PRIVATE FUNCTIONS --- REM ----------------------------------------------------------------------------------------------------------------------- REM ----------------------------------------------------------------------------------------------------------------------- Public Function _AppendChunk(ByVal psFieldName As String, ByRef pvChunk As Variant, piChunkType) As Boolean ' Write chunk at the end of the file dedicated to the given field If _ErrorHandler() Then On Local Error GoTo Error_Function Dim oFileAccess As Object Dim i As Integer, oChunk As Object, iChunk As Integer ' Do nothing if chunk meaningless _AppendChunk = False If IsNull(pvChunk) Then GoTo Exit_Function If IsArray(pvChunk) Then If UBound(pvChunk) < LBound(pvChunk) Then GoTo Exit_Function ' Empty array End If ' Find or create relevant chunk entry iChunk = -1 For i = 0 To UBound(_ManageChunks) Set oChunk = _ManageChunks(i) If oChunk.FieldName = psFieldName Then iChunk = i Exit For End If Next i If iChunk = -1 Then _AppendChunkInit(psFieldName) iChunk = UBound(_ManageChunks) End If Set oChunk = _ManageChunks(iChunk) With oChunk If Not .ChunksRequested Then ' First chunk .ChunksRequested = True .ChunkType = piChunkType .FileName = Utils._GetRandomFileName(_Name) Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") .FileHandler = oFileAccess.openFileWrite(.FileName) End If .FileHandler.writeBytes(pvChunk) End With _AppendChunk = True Exit_Function: Exit Function Error_Function: TraceError(TRACEABORT, Err, "Recordset._AppendChunk", Erl) GoTo Exit_Function End Function ' AppendChunk V1.5.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _AppendChunkClose(ByVal pbCancel As Boolean) As Boolean ' Stores file content to database field(s) ' Called from Update() [pbCancel = False] or CancelUpdate() [pbCancel = True] If _ErrorHandler() Then On Local Error GoTo Error_Function Dim oFileAccess As Object, oStream As Object, lFileLength As Long, oField As Object Dim i As Integer, oChunk As Object _AppendChunkClose = False For i = 0 To UBound(_ManageChunks) Set oChunk = _ManageChunks(i) With oChunk If Not .ChunksRequested Then GoTo Exit_Function If IsNull(.FileHandler) Then GoTo Exit_Function .Filehandler.closeOutput Set oFileAccess = CreateUnoService("com.sun.star.ucb.SimpleFileAccess") ' Copy file to field If Not pbCancel Then Set oStream = oFileAccess.openFileRead(.FileName) lFileLength = oStream.getLength() If lFileLength > 0 Then Set oField = RowSet.getColumns.getByName(.FieldName) Select Case .ChunkType Case vbByte oField.updateBinaryStream(oStream, lFileLength) ' Case vbString ' DOES NOT WORK FOR CHARACTER TYPES ' oField.updateCharacterStream(oStream, lFileLength) End Select End If oStream.closeInput() End If If oFileAccess.exists(.FileName) Then oFileAccess.kill(.FileName) End With Next i Set _ManageChunks = Array() _AppendChunkClose = True Exit_Function: Exit Function Error_Function: TraceError(TRACEABORT, Err, "Recordset._AppendChunkClose", Erl) GoTo Exit_Function End Function ' AppendChunkClose V1.5.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Function _AppendChunkInit(psFieldName As String) As Boolean ' Initialize chunks manager Dim iSize As Integer iSize = UBound(_ManageChunks) + 1 ReDim Preserve _ManageChunks(0 To iSize) Set _ManageChunks(iSize) = New ChunkDescriptor With _ManageChunks(iSize) .ChunksRequested = False .FieldName = psFieldName .FileName = "" Set .FileHandler = Nothing End With End Function ' AppendChunkInit V1.5.0 REM ----------------------------------------------------------------------------------------------------------------------- Public Sub _Initialize(ByVal Optional pvFilter As Variant, Optional poRowSet As Object) ' Initialize new recordset Dim sFilter As String If _Command = "" Then Exit Sub If _ErrorHandler() Then On Local Error Goto Error_Sub If VarType(pvFilter) = vbError Then sFilter = "" ElseIf IsMissing(pvFilter) Then sFilter = "" Else sFilter = pvFilter End If If Not IsMissing(poRowSet) Then ' Clone Set RowSet = poRowSet.createResultSet() _IsClone = True RowSet.last() ' Solves bookmark desynchro when parent bookmark is used ?!? Else Set RowSet = CreateUnoService("com.sun.star.sdb.RowSet") _IsClone = False With RowSet If IsNull(.ActiveConnection) Then Set .ActiveConnection = _ParentDatabase.Connection .CommandType = _CommandType .Command = _Command If _ForwardOnly Then .ResultSetType = com.sun.star.sdbc.ResultSetType.FORWARD_ONLY _ Else .ResultSetType = com.sun.star.sdbc.ResultSetType.SCROLL_SENSITIVE If _PassThrough Then .EscapeProcessing = False _ Else .EscapeProcessing = True If _ReadOnly Then .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.READ_ONLY .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_UNCOMMITTED ' Dirty read Else .ResultSetConcurrency = com.sun.star.sdbc.ResultSetConcurrency.UPDATABLE .TransactionIsolation = com.sun.star.sdbc.TransactionIsolation.READ_COMMITTED End If End With If sFilter <> "" Then ' Filter must be set before execute() RowSet.Filter = sFilter RowSet.ApplyFilter = True End If On Local Error Goto SQL_Error RowSet.execute() On Local Error Goto Error_Sub End If _DataSet = True 'If the Recordset contains no records, the BOF and EOF properties are True, and there is no current record. _BOF = ( RowSet.IsRowCountFinal And RowSet.RowCount = 0 ) _EOF = _BOF Exit_Sub: Exit Sub SQL_Error: TraceError(TRACEFATAL, ERRSQLSTATEMENT, Utils._CalledSub(), 0, , _Command) Goto Exit_Sub Error_Sub: TraceError(TRACEABORT, Err, "Recordset._Initialize", Erl) GoTo Exit_Sub End Sub ' _Initialize REM ----------------------------------------------------------------------------------------------------------------------- Public Function _Move(pvTarget As Variant, ByVal Optional pvBookmark As Variant, ByVal Optional pbAbsolute As Boolean) As Boolean 'Move to the first, last, next, or previous record in a specified Recordset object and make that record the current record. Dim cstThisSub As String cstThisSub = "Recordset.Move" & Iif(VarType(pvTarget) = vbString, pvTarget, "") Utils._SetCalledSub(cstThisSub) If _ErrorHandler() Then On Local Error Goto Error_Function If IsNull(RowSet) Then Goto Trace_Closed If Not _DataSet Then Goto Trace_NoData If _BOF And _EOF Then Goto Trace_NoData _Move = False CancelUpdate() ' Any Move cancels all updates, even Move(0) ! Dim l As Long, lRow As Long With RowSet Select Case VarType(pvTarget) Case vbString Select Case UCase(pvTarget) Case "FIRST" If _ForwardOnly Then If Not ( .isBeforeFirst() Or .isFirst() ) Then Goto Trace_Forward Else .next() End If Else .first() End If Case "LAST" If _ForwardOnly Then If .isAfterLast() Then Goto Trace_Forward Do While Not ( .isRowCountFinal And .Row = .RowCount ) ' isLast() = True after reading of first records chunk .next() Loop Else .last() End If Case "NEXT" If _EOF Then Goto Trace_OutOfRange .next() Case "PREVIOUS" If _ForwardOnly Then Goto Trace_Forward If _BOF Then Goto Trace_OutOfRange .previous() End Select Case Else ' Relative or absolute move If IsMissing(pbAbsolute) Then pbAbsolute = False ' Relative move is default If _ForwardOnly And pvTarget < 0 then Goto Trace_Forward If IsMissing(pvBookmark) Then If pvTarget = 0 Then Goto Exit_Function ' Do nothing If _ForwardOnly Then If pbAbsolute Then lRow = .getRow() Else lRow = 0 For l = 1 To pvTarget - lRow If .isAfterLast() Then Exit For .next() Next l Else If pbAbsolute Then .absolute(pvTarget) Else .relative(pvTarget) End If Else ' Move is always relative when bookmark argument present If _ForwardOnly Then Goto Trace_Forward If pvTarget = 0 Then .moveToBookmark(pvBookmark) Else .moveRelativeToBookmark(pvBookmark, pvTarget) End If End If End Select _BOF = .isBeforeFirst() ' https://forum.openoffice.org/en/forum/viewtopic.php?f=47&t=76640 _EOF = .isAfterlast() If _BOF Or _EOF Then _Move = False Else If .rowDeleted() Then Goto Error_RowDeleted If .rowUpdated() Then .refreshRow() _Move = True End If End With Exit_Function: Utils._ResetCalledSub(cstThisSub) Exit Function Exit_Close: ' Force close of recordset when error raised mClose() Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub, Erl) GoTo Exit_Close Trace_Forward: TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0) Goto Exit_Close Trace_NoData: TraceError(TRACEFATAL, ERRRECORDSETNODATA, Utils._CalledSub(), 0) Goto Exit_Close Trace_OutOfRange: TraceError(TRACEFATAL, ERRRECORDSETRANGE, Utils._CalledSub(), 0) Goto Exit_Close Error_RowDeleted: TraceError(TRACEFATAL, ERRROWDELETED, Utils._CalledSub(), 0) Goto Exit_Function Trace_Closed: TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) Goto Exit_Close End Function ' Move REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertiesList() As Variant _PropertiesList = Array("AbsolutePosition", "BOF", "Bookmarkable", "Bookmark", "EditMode" _ , "EOF", "Filter", "LastModified", "Name", "ObjectType" , "RecordCount" _ ) End Function ' _PropertiesList REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertyGet(ByVal psProperty As String) As Variant ' Return property value of the psProperty property name If _ErrorHandler() Then On Local Error Goto Error_Function Dim cstThisSub As String cstThisSub = "Recordset.get" Utils._SetCalledSub(cstThisSub & psProperty) _PropertyGet = EMPTY Select Case UCase(psProperty) Case UCase("AbsolutePosition") If IsNull(RowSet) Then Goto Trace_Closed With RowSet Select Case True Case _BOF And _EOF : _PropertyGet = -1 Case .isBeforeFirst() Or .isAfterLast() : _PropertyGet = -1 Case Else : _PropertyGet = .getRow() ' Not getRow() - 1 as MSAccess requires End Select End With Case UCase("BOF") If IsNull(RowSet) Then Goto Trace_Closed Select Case True Case _BOF And _EOF : _PropertyGet = True Case RowSet.isBeforeFirst() : _PropertyGet = True Case Else : _PropertyGet = False End Select Case UCase("Bookmarkable") If IsNull(RowSet) Then Goto Trace_Closed If _ForwardOnly Then _PropertyGet = False Else _PropertyGet = RowSet.IsBookmarkable Case UCase("Bookmark") If IsNull(RowSet) Then Goto Trace_Closed If RowSet.IsBookmarkable And Not _ForwardOnly Then If _BOF Or _EOF Then _PropertyGet = Null Else _PropertyGet = RowSet.getBookmark() Else _PropertyGet = Null If _ForwardOnly Then Goto Trace_Forward End If Case UCase("EditMode") If IsNull(RowSet) Then Goto Trace_Closed _PropertyGet = _EditMode Case UCase("EOF") If IsNull(RowSet) Then Goto Trace_Closed Select Case True Case _BOF And _EOF : _PropertyGet = True Case RowSet.isAfterLast() : _PropertyGet = True Case Else : _PropertyGet = False End Select Case UCase("Filter") If IsNull(RowSet) Then Goto Trace_Closed _PropertyGet = RowSet.Filter Case UCase("LastModified") If IsNull(RowSet) Then Goto Trace_Closed If RowSet.IsBookmarkable And Not _ForwardOnly Then _PropertyGet = _BookmarkLastModified Else _PropertyGet = Null If _ForwardOnly Then Goto Trace_Forward End If Case UCase("Name") _PropertyGet = _Name Case UCase("ObjectType") _PropertyGet = _Type Case UCase("RecordCount") If IsNull(RowSet) Then Goto Trace_Closed _PropertyGet = RowSet.RowCount Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub(cstThisSub & psProperty) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, , psProperty) _PropertyGet = EMPTY Goto Exit_Function Trace_Forward: TraceError(TRACEFATAL, ERRRECORDSETFORWARD, Utils._CalledSub(), 0) Goto Exit_Function Trace_Closed: TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, cstThisSub & "._PropertyGet", Erl) _PropertyGet = EMPTY GoTo Exit_Function End Function ' _PropertyGet REM ----------------------------------------------------------------------------------------------------------------------- Private Function _PropertySet(ByVal psProperty As String, ByVal pvValue As Variant) As Boolean Dim cstThisSub As String cstThisSub = "Recordset.set" Utils._SetCalledSub(cstThisSub & psProperty) If _ErrorHandler() Then On Local Error Goto Error_Function _PropertySet = True 'Execute Dim iArgNr As Integer Dim oObject As Object If _IsLeft(_A2B_.CalledSub, "Recordset.") Then iArgNr = 1 Else iArgNr = 2 Select Case UCase(psProperty) Case UCase("AbsolutePosition") If Not Utils._CheckArgument(pvValue, iArgNr, Utils._AddNumeric(), , False) Then Goto Trace_Error_Value If pvValue < 1 Then Goto Trace_Error_Value _Move(pvValue, , True) Case UCase("Bookmark") If IsNull(RowSet) Then Goto Trace_Closed _Move(0, pvValue) Case UCase("Filter") If IsNull(RowSet) Then Goto Trace_Closed If Not Utils._CheckArgument(pvValue, iArgNr, vbString, , False) Then Goto Trace_Error_Value _Filter = _ParentDatabase._ReplaceSquareBrackets(pvValue) Case Else Goto Trace_Error End Select Exit_Function: Utils._ResetCalledSub(cstThisSub & psProperty) Exit Function Trace_Error: TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty) _PropertySet = False Goto Exit_Function Trace_Error_Value: TraceError(TRACEFATAL, ERRPROPERTYVALUE, Utils._CalledSub(), 0, 1, Array(pvValue, psProperty)) _PropertySet = False Goto Exit_Function Trace_Closed: TraceError(TRACEFATAL, ERRRECORDSETCLOSED, Utils._CalledSub(), 0) Goto Exit_Function Error_Function: TraceError(TRACEABORT, Err, Utils._CalledSub(), Erl) _PropertySet = False GoTo Exit_Function End Function ' _PropertySet