pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
8b51f30e1433ea7f1c738773e029dd150c596fb1
lazarus-ccr/components/fpspreadsheet/source/dataset/fpsdataset.pas

2324 lines
68 KiB
ObjectPascal
Raw Blame History

{@@ ----------------------------------------------------------------------------
Unit **fpsDataset** implements a TDataset based on spreadsheet data.
This way spreadsheets can be accessed in a database-like manner.
Of course, it is required that all cells in a column have the same type.
AUTHORS: Werner Pamler
LICENSE: See the file COPYING.modifiedLGPL.txt, included in the Lazarus
distribution, for details about the license.
References:
* https://www.delphipower.xyz/guide_8/building_custom_datasets.html
* http://etutorials.org/Programming/mastering+delphi+7/Part+III+Delphi+Database-Oriented+Architectures/Chapter+17+Writing+Database+Components/Building+Custom+Datasets/
* http://216.19.73.24/articles/customds.asp
* https://delphi.cjcsoft.net/viewthread.php?tid=44220
Much of the code is adapted from TMemDataset.
Current status (Sept 12, 2021):
Working
* Field defs: determined automatically from file
* Field defs defined by user: working (requires AutoFieldDefs = false)
* Fields: working
* Field types: ftFloat, ftInteger, ftAutoInc, ftByte, ftSmallInt, ftWord, ftLargeInt,
ftCurrency, ftBCD, ftFmtBCD, ftDateTime, ftDate, ftTime, ftString, ftFixedChar,
ftBoolean, ftWideString, ftFixedWideString, ftMemo
* Locate: working
* Lookup: working
* Edit, Delete, Insert, Append, Post, Cancel: working
* NULL fields: working
* GetBookmark, GotoBookmark: working
* Filtering by OnFilter event and by Filter property: working.
* Persistent and calculated fields working
* Sorting by method SortOnFields
* Selecting specific spreadsheet file format or automatic format detection.
Planned but not yet working
' Field defs: Required, Unique etc possibly not supported ATM - to be tested
* IndexDefs: not implemented
Issues
* Text cells should be converted to text fields in UTF8 encoding. However,
TField supports codepages only in FPC 3.2+.
* Manually deleting a fielddef removes it from the object tree, but not from
the lfm file.
* Insert initially adds a new record before the current position, but after
Post the new record is moved to the end.
-------------------------------------------------------------------------------}
unit fpsDataset;
{$mode ObjFPC}{$H+}
{$I ../fps.inc}
{$R ../../resource/fpsdatasetreg.res}
{$WARN 6058 off : Call to subroutine "$1" marked as inline is not inlined}
interface
uses
Classes, SysUtils, DB, BufDataset_Parser,
fpSpreadsheet, fpsTypes, fpsUtils, {%H-}fpsAllFormats;
type
TRowIndex = Int64;
TColIndex = Int64;
PPCell = ^PCell;
TsSortOptionsArray = array of TsSortOptions;
{ TsFieldDef }
TsFieldDef = class(TFieldDef)
private
FColIndex: TColIndex;
public
constructor Create(ACollection: TCollection); override;
constructor Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType;
ASize: Integer; ARequired: Boolean; AFieldNo: Longint; AColIndex: TColIndex
{$IF FPC_FullVersion >= 30200}; ACodePage: TSystemCodePage = CP_UTF8{$IFEND}
); overload;
procedure Assign(ASource: TPersistent); override;
published
property ColIndex: TColIndex read FColIndex write FColIndex default -1;
end;
{ TsFieldDefs }
TsFieldDefs = class(TFieldDefs)
protected
class function FieldDefClass : TFieldDefClass; override;
end;
{ TsRecordInfo }
TsRecordInfo = record
Bookmark: PCell; // Pointer to a cell in the bookmarked row.
BookmarkFlag: TBookmarkFlag;
end;
PsRecordInfo = ^TsRecordInfo;
{ TsWorksheetDataset }
TsWorksheetDataset = class(TDataset)
private
FFileName: TFileName; // Name of the spreadsheet file
FSheetName: String; // Name of the worksheet used by the dataset
FWorkbook: TsWorkbook; // Underlying workbook providing the data
FWorksheet: TsWorksheet; // Underlying worksheet providing the data
FRecNo: Integer; // Current record number
FFirstRow: TRowIndex; // WorksheetIndex of the first record
FLastRow: TRowIndex; // Worksheet index of the last record
FLastCol: TColIndex; // Worksheet index of the last column
FRecordCount: Integer; // Number of records between first and last data rows
FRecordBufferSize: Integer; // Size of the record buffer
FTotalFieldSize: Integer; // Total size of the field data
FFieldOffsets: array of Integer; // Offset to field start in buffer
FModified: Boolean; // Flag to show that workbook needs saving
FFilterBuffer: TRecordBuffer; // Buffer for filtered record
FTableCreated: boolean; // Flag telling that the table has been created
FAutoFieldDefs: Boolean; // Automatically detect fielddefs in the worksheet
FAutoFieldDefStringSize: Integer; // Default size of automatically detected string fields
FIsOpen: boolean; // Flag storing that the dataset is open
FParser: TBufDatasetParser; // Parser for filter expressions
FAutoIncValue: Integer; // Automatically incremented value
FAutoIncField: TAutoIncField; // Field which is automatically incremented
FSortParams: TsSortParams; // Parameters for sorting
FAutoFileFormat: Boolean; // Automatically detect the spreadsheet file format
FFileFormat: TsSpreadsheetFormat; // Format of the spreadsheet file
private
procedure CreateSortParams(const FieldNames: string;
const Options: TsSortOptionsArray);
procedure FixFieldDefs;
// function FixFieldName(const AText: String): String;
procedure FreeSortParams;
function GetActiveBuffer(out Buffer: TRecordBuffer): Boolean;
function GetBookmarkCellFromRecNo(ARecNo: Integer): PCell;
function GetCurrentRowIndex: TRowIndex;
function GetFirstDataRowIndex: TRowIndex;
function GetLastDataRowIndex: TRowIndex;
function GetNullMaskPtr(Buffer: TRecordBuffer): Pointer;
function GetNullMaskSize: Integer;
function GetRecordInfoPtr(Buffer: TRecordBuffer): PsRecordInfo;
function GetRowIndexFromRecNo(ARecNo: Integer): TRowIndex;
procedure SetAutoFieldDefStringSize(Value: Integer);
procedure SetCurrentRow(ARow: TRowIndex);
protected
// methods inherited from TDataset
function AllocRecordBuffer: TRecordBuffer; override;
procedure ClearCalcFields(Buffer: TRecordBuffer); override;
procedure DoBeforeOpen; override;
class function FieldDefsClass : TFieldDefsClass; override;
procedure FreeRecordBuffer(var Buffer: TRecordBuffer); override;
procedure GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
function GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag; override;
function GetRecNo: LongInt; override;
function GetRecord(Buffer: TRecordBuffer; GetMode: TGetMode;
DoCheck: Boolean): TGetResult; override;
function GetRecordCount: LongInt; override;
function GetRecordSize: Word; override;
procedure InternalAddRecord(Buffer: Pointer; DoAppend: Boolean); override;
procedure InternalClose; override;
procedure InternalDelete; override;
procedure InternalFirst; override;
procedure InternalGotoBookmark(ABookmark: Pointer); override;
procedure InternalInitFieldDefs; override;
procedure InternalInitRecord(Buffer: TRecordBuffer); override;
procedure InternalLast; override;
procedure InternalOpen; override;
procedure InternalPost; override;
procedure InternalSetToRecord(Buffer: TRecordBuffer); override;
function IsCursorOpen: Boolean; override;
procedure SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer); override;
procedure SetBookmarkFlag(Buffer: TRecordBuffer; Value: TBookmarkFlag); override;
procedure SetFiltered(Value: Boolean); override;
procedure SetFilterText(const Value: String); override;
procedure SetRecNo(Value: Integer); override;
// new methods
procedure AllocBlobPointers(Buffer: TRecordBuffer);
procedure CalcFieldOffsets;
function ColIndexFromField(AField: TField): TColIndex;
procedure DetectFieldDefs;
function FilterRecord(Buffer: TRecordBuffer): Boolean;
procedure FreeBlobPointers(Buffer: TRecordBuffer);
procedure FreeWorkbook;
function GetTotalFieldSize: Integer;
procedure LoadWorksheetToBuffer(Buffer: TRecordBuffer; ARecNo: Integer);
function LocateRecord(const KeyFields: string; const KeyValues: Variant;
Options: TLocateOptions; out ARecNo: integer): Boolean;
procedure ParseFilter(const AFilter: STring);
procedure SetupAutoInc;
procedure Sort;
procedure WriteBufferToWorksheet(Buffer: TRecordBuffer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function AddFieldDef(AName: String; ADataType: TFieldType; ASize: Integer = 0;
AColIndex: Integer = -1; ACodePage: TSystemCodePage = CP_UTF8): TsFieldDef; overload;
function BookmarkValid(ABookmark: TBookmark): Boolean; override;
procedure Clear;
procedure Clear(ClearDefs: Boolean);
function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint; override;
procedure CopyFromDataset(ADataset: TDataset;
const AWorkbookFileName, ASheetName: String;
ASourceCodePage: TSystemCodePage = CP_UTF8);
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override;
procedure CreateTable;
procedure Flush;
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
function Locate(const KeyFields: String; const KeyValues: Variant;
Options: TLocateOptions): boolean; override;
function Lookup(const Keyfields: String; const KeyValues: Variant;
const ResultFields: String): Variant; override;
procedure SetFieldData(Field: TField; Buffer: Pointer); override;
procedure SortOnField(const FieldName: String); overload;
procedure SortOnField(const FieldName: String; const Options: TsSortOptions); overload;
procedure SortOnFields(const FieldNames: String); overload;
procedure SortOnFields(const FieldNames: String; const Options: TsSortOptionsArray); overload;
{ Defines the field size of string fields to be used by FieldDef autodetection.
When AutoFieldDefStringSize is 0 field size depends on the longest text in
the worksheet column. }
property AutoFieldDefStringSize: Integer read FAutoFieldDefStringSize write SetAutoFieldDefStringSize default 0;
property Modified: boolean read FModified;
published
property AutoFieldDefs: Boolean read FAutoFieldDefs write FAutoFieldDefs default true;
property AutoFileFormat: Boolean read FAutoFileFormat write FAutoFileFormat default true;
property FileFormat: TsSpreadsheetFormat read FFileFormat write FFileFormat default sfUser;
property FileName: TFileName read FFileName write FFileName;
property SheetName: String read FSheetName write FSheetName;
// inherited properties
property Active;
property AutoCalcFields;
property FieldDefs;
property Filter;
property Filtered;
property FilterOptions default [];
// inherited events
property AfterCancel;
property AfterClose;
property AfterDelete;
property AfterEdit;
property AfterInsert;
property AfterOpen;
property AfterPost;
property AfterRefresh;
property AfterScroll;
property BeforeCancel;
property BeforeClose;
property BeforeDelete;
property BeforeEdit;
property BeforeInsert;
property BeforeOpen;
property BeforePost;
property BeforeRefresh;
property BeforeScroll;
property OnCalcFields;
property OnDeleteError;
property OnEditError;
property OnFilterRecord;
property OnNewRecord;
property OnPostError;
end;
procedure Register;
implementation
uses
LazUTF8, LazUTF16, LConvEncoding, Math, TypInfo, Variants, FmtBCD, fpsNumFormat;
const // This are the field types of FPC 3.3.x
ftSupported = [ftString, ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
ftCurrency, ftBCD, ftDate, ftTime, ftDateTime,
{ftBytes, ftVarBytes, } ftAutoInc, ftBlob, ftMemo,
{ftGraphic, ftFmtMemo, ftParadoxOle, ftDBaseOle, ftTypedBinary, ftCursor, }
ftFixedChar, ftWideString, ftLargeint,
{ftADT, ftArray, ftReference, ftDataSet, ftOraBlob, ftOraClob, ftVariant,
ftInterface, ftIDispatch, ftGuid, ftTimeStamp,}
ftFMTBCD, ftFixedWideChar, ftWideMemo
{
, ftOraTimeStamp, ftOraInterval, ftLongWord, ftShortint,
}
{$IF FPC_FullVersion >= 30300}
, ftByte
{$IFEND}
{, ftExtended}
];
{ Null mask handling
The null mask is a part of the record buffer which stores in its bits the
information which fields are NULL. Since all bytes in a new record all bits
are cleared and a new record has NULL fields the logic must "inverted", i.e.
a 0-bit means: "field is NULL", and a 1-bit means "field is not NULL". }
{ Clears the information that the field is null by setting the corresponding
bit in the null mask. }
procedure ClearFieldIsNull(NullMask: PByte; FieldNo: Integer);
var
n: Integer = 0;
m: Integer = 0;
begin
DivMod(FieldNo - 1, 8, n, m);
inc(NullMask, n);
// Set the bit to indicate that the field is not NULL.
NullMask^ := NullMask^ or (1 shl m);
end;
{ Returns true when the field is null, i.e. when its bit in the null mask is not set. }
function GetFieldIsNull(NullMask: PByte; FieldNo: Integer): Boolean;
var
n: Integer = 0;
m: Integer = 0;
begin
DivMod(FieldNo - 1, 8, n, m);
inc(NullMask, n);
Result := NullMask^ and (1 shl m) = 0;
end;
{ Clears in the null mask the bit corresponding to FieldNo to indicate that the
associated field is NULL. }
procedure SetFieldIsNull(NullMask: PByte; FieldNo: Integer);
var
n: Integer = 0;
m: Integer = 0;
begin
DivMod(FieldNo - 1, 8, n, m);
inc(NullMask, n);
NullMask^ := nullMask^ and not (1 shl m);
end;
{$IFDEF FPS_NO_LAZUTF16}
// Here we borrow some code from newer Lazarus versions to make the package
// compile also with old versions.
function UTF16CharacterLength(p: PWideChar): integer;
// returns length of UTF16 character in number of words
// The endianess of the machine will be taken.
begin
if p<>nil then begin
if (ord(p[0]) < $D800) or (ord(p[0]) > $DFFF) then
Result:=1
else
Result:=2;
end else begin
Result:=0;
end;
end;
function UTF16CharStart(P: PWideChar; Len, CharIndex: PtrInt): PWideChar;
// Len is the length in words of P.
// CharIndex is the position of the desired UnicodeChar (starting at 0).
var
CharLen: LongInt;
begin
Result:=P;
if Result=nil then Exit;
while (CharIndex>0) and (Len>0) do
begin
CharLen:=UTF16CharacterLength(Result);
dec(Len,CharLen);
dec(CharIndex);
inc(Result,CharLen);
end;
if (CharIndex<>0) or (Len<0) then
Result:=nil;
end;
function UTF16Copy(const s: UnicodeString; StartCharIndex, CharCount: PtrInt): Unicodestring;
// returns substring
var
StartPos: PWideChar;
EndPos: PWideChar;
MaxBytes: PtrInt;
begin
StartPos:=UTF16CharStart(PWideChar(s),length(s),StartCharIndex-1);
if StartPos=nil then
Result:=''
else begin
MaxBytes:=PtrInt(PWideChar(s)+length(s)-StartPos);
EndPos:=UTF16CharStart(StartPos,MaxBytes,CharCount);
if EndPos=nil then
Result:=copy(s,StartPos-PWideChar(s)+1,MaxBytes)
else
Result:=copy(s,StartPos-PWideChar(s)+1,EndPos-StartPos);
end;
end;
{$ENDIF}
{ TsFieldDef }
constructor TsFieldDef.Create(ACollection: TCollection);
begin
inherited;
FColIndex := -1;
end;
constructor TsFieldDef.Create(AOwner: TFieldDefs; const AName: string;
ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint;
AColIndex: TColIndex
{$IF FPC_FullVersion >= 30200}
; ACodePage: TSystemCodePage = CP_UTF8
{$IFEND}); overload;
begin
inherited Create(AOwner, AName, ADataType, ASize, ARequired, AFieldNo{$IF FPC_FullVersion >= 30200}, ACodePage{$IFEND});
FColIndex := AColIndex;
end;
procedure TsFieldDef.Assign(ASource: TPersistent);
begin
if ASource is TsFieldDef then
FColIndex := TsFieldDef(ASource).FColIndex;
inherited Assign(ASource);
end;
{ TsFieldDefs }
class function TsFieldDefs.FieldDefClass: TFieldDefClass;
begin
Result := TsFieldDef;
end;
{ TsBlobData }
type
TsBlobData = record
Data: TBytes;
// dummy: Int64;
end;
PsBlobData = ^TsBlobData;
{ TsBlobStream }
type
TsBlobStream = class(TMemoryStream)
private
FField: TBlobField;
FDataSet: TsWorksheetDataSet;
FMode: TBlobStreamMode;
FModified: Boolean;
procedure LoadBlobData;
procedure SaveBlobData;
public
constructor Create(Field: TBlobField; Mode: TBlobStreamMode);
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
end;
constructor TsBlobStream.Create(Field: TBlobField; Mode: TBlobStreamMode);
begin
inherited Create;
FField := Field;
FMode := Mode;
FDataset := FField.Dataset as TsWorksheetDataset;
if Mode <> bmWrite then
LoadBlobData;
end;
destructor TsBlobStream.Destroy;
begin
if FModified then
SaveBlobData;
inherited Destroy;
end;
// Copies the BLOB field data from the active buffer into the stream
procedure TsBlobStream.LoadBlobData;
var
buffer: TRecordBuffer;
nullMask: Pointer;
begin
Self.Size := 0;
if FDataset.GetActiveBuffer(buffer) then
begin
nullMask := FDataset.GetNullMaskPtr(buffer);
inc(buffer, FDataset.FFieldOffsets[FField.FieldNo-1]);
Size := 0;
if not GetFieldIsNull(nullMask, FField.FieldNo) then
with PsBlobData(buffer)^ do
Write(Data[0], Length(Data)); // Writes the data into the stream
Position := 0;
// SaveToFile('test.txt');
end;
Position := 0;
end;
function TsBlobStream.Read(var Buffer; Count: LongInt): LongInt;
begin
Result := inherited Read(Buffer, Count);
end;
// Writes the stream data to the buffer of the BLOB field.
// Take care of the null mask!
procedure TsBlobStream.SaveBlobData;
var
buffer: TRecordBuffer;
nullMask: Pointer;
begin
if FDataset.GetActiveBuffer(buffer) then
begin
nullMask := FDataset.GetNullMaskPtr(buffer);
inc(buffer, FDataset.FFieldOffsets[FField.FieldNo-1]);
Position := 0;
if Size = 0 then
SetFieldIsNull(nullMask, FField.FieldNo)
else
with PsBlobData(buffer)^ do
begin
SetLength(Data, Size);
Read(Data[0], Size); // Reads the stream data to put them into the buffer
ClearFieldIsNull(nullMask, FField.FieldNo);
end;
Position := 0;
end;
FModified := false;
end;
function TsBlobStream.Write(const Buffer; Count: LongInt): LongInt;
begin
Result := inherited Write(Buffer, Count);
FModified := true;
end;
{ TsWorksheetDataset }
constructor TsWorksheetDataset.Create(AOwner: TComponent);
begin
inherited;
FAutoFieldDefs := true;
FAutoFileFormat := true;
FFileFormat := sfUser;
FRecordCount := -1;
FTotalFieldSize := -1;
FRecordBufferSize := -1;
FRecNo := -1;
FAutoIncValue := -1;
BookmarkSize := SizeOf(TRowIndex);
end;
destructor TsWorksheetDataset.Destroy;
begin
Close;
inherited;
end;
{ Adds a FieldDef to the FieldDefs collection. This is an adapted version
for this dataset class because defines the column index of the field in the
worksheet, and, in case of FPC 3.2+, creates string fields with UTF8 codepage.
ALWAYS USE THIS METHOD TO CREATE FIELDDEFS.
When the fielddef is added in the "normal" way (i.e. FieldDefs.Add(...) ),
the column index is not specified and the dataset will not work!
The argument ACodePage is ignored when FPC is older than v3.2. }
function TsWorksheetDataset.AddFieldDef(
AName: String; ADataType: TFieldType; ASize: Integer = 0; AColIndex: Integer = -1;
ACodePage: TSystemCodePage = CP_UTF8): TsFieldDef;
begin
if not (ADataType in ftSupported) then
DatabaseError('Field type not supported.');
if AColIndex = -1 then
AColIndex := FieldDefs.Count;
Result := TsFieldDef.Create(TsFieldDefs(FieldDefs),
AName, ADataType, ASize, false, FieldDefs.Count+1, AColIndex
{$IF FPC_FullVersion >= 30200}, ACodePage {$IFEND}
);
end;
procedure TsWorksheetDataset.AllocBlobPointers(Buffer: TRecordBuffer);
var
i: Integer;
f: TField;
offset: Integer;
begin
for i := 0 to FieldCount-1 do
begin
f := Fields[i];
if f.DataType in [ftMemo{, ftGraphic}] then
begin
offset := FFieldOffsets[f.FieldNo-1];
// FillChar(PsBlobData(Buffer + offset)^, SizeOf(TsBlobData), 0);
PsBlobData(Buffer + offset)^.Data := nil;
// SetLength(PsBlobData(Buffer + offset)^.Data, 0);
end;
end;
end;
{ Allocates a buffer for the dataset
Structure of the TsWorksheetDataset buffer
+---------------------------------------------------+-----------------------+
| field data | null mask | record info | calculated fields |
+---------------------------------------------------+-----------------------+
<-------------------- GetRecordSize ----------------> <-- CalcFieldsSize --->
}
function TsWorksheetDataset.AllocRecordBuffer: TRecordBuffer;
var
n: Integer;
begin
n := GetRecordSize + CalcFieldsSize;
GetMem(Result, n);
FillChar(Result^, n, 0);
AllocBlobPointers(Result);
end;
{ Returns whether the specified bookmark is valid, i.e. the worksheet row index
associated with the bookmark cell is between first and last data rows. }
function TsWorksheetDataset.BookmarkValid(ABookmark: TBookmark): Boolean;
var
bookmarkCell: PCell;
begin
Result := False;
if ABookMark = nil then exit;
bookmarkCell := PPCell(ABookmark)^;
Result := (bookmarkCell^.Row >= GetFirstDataRowIndex) and
(bookmarkCell^.Row <= GetLastDataRowIndex);
end;
procedure TsWorksheetDataset.CalcFieldOffsets;
var
i: Integer;
fs: Integer; // field size
begin
SetLength(FFieldOffsets, FieldDefs.Count);
FFieldOffsets[0] := 0;
for i := 0 to FieldDefs.Count-2 do
begin
case FieldDefs[i].DataType of
ftString, ftFixedChar:
{$IF FPC_FullVersion >= 30200}
if FieldDefs[i].Codepage = CP_UTF8 then
fs := FieldDefs[i].Size*4 + 1
// a UTF8 char point requires 1-4 bytes - we must reserve the maximum!
else
{$IFEND}
fs := FieldDefs[i].Size + 1; // +1 for zero termination
ftWideString, ftFixedWideChar:
fs := (FieldDefs[i].Size + 1) * 2;
ftInteger, ftAutoInc:
fs := SizeOf(Integer);
{$IF FPC_FullVersion >= 30300}
ftByte:
fs := SizeOf(Byte);
{$IFEND}
ftSmallInt:
fs := SizeOf(SmallInt);
ftWord:
fs := SizeOf(Word);
ftLargeInt:
fs := Sizeof(LargeInt);
ftFloat, ftCurrency: // Currency is expected by TCurrencyField as double
fs := SizeOf(Double);
ftBCD:
fs := SizeOf(Currency); // BCD is expected by TBCDField as currency
ftFmtBCD:
fs := SizeOf(TBCD); // The TFmtBCDField expects data as true TBCD.
ftDateTime, ftDate, ftTime:
fs := SizeOf(TDateTime); // date/time values are TDateTime in the buffer
ftBoolean:
fs := SizeOf(WordBool); // boolean is expected by TBooleanField to be WordBool
ftMemo:
fs := SizeOf(TsBlobData);
else
DatabaseError(Format('Field data type %s not supported.', [
GetEnumName(TypeInfo(TFieldType), integer(FieldDefs[i].DataType))
]));
end;
FFieldOffsets[i+1] := FFieldOffsets[i] + fs;
end;
end;
procedure TsWorksheetDataset.Clear;
begin
Clear(true);
end;
procedure TsWorksheetDataset.Clear(ClearDefs: Boolean);
begin
FRecNo := -1;
FRecordCount := -1;
FTotalFieldSize := -1;
FRecordBufferSize := -1;
if Active then
Resync([]);
if ClearDefs then
begin
Close;
FieldDefs.Clear;
FTableCreated := false;
end;
end;
procedure TsWorksheetDataset.ClearCalcFields(Buffer: TRecordBuffer);
begin
FillChar(Buffer[RecordSize], CalcFieldsSize, 0);
end;
{ Determines the worksheet column index for a specific field }
function TsWorksheetDataset.ColIndexFromField(AField: TField): TColIndex;
var
fieldDef: TsFieldDef;
begin
fieldDef := AField.FieldDef as TsFieldDef;
if fieldDef <> nil then
Result := fieldDef.ColIndex
else
Result := -1;
end;
// Compares two bookmarks (row indices). This tricky handling of nil is
// "borrowed" from TMemDataset
function TsWorksheetDataset.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
const
r: array[Boolean, Boolean] of ShortInt = ((2,-1),(1,0));
var
cell1, cell2: PCell;
begin
Result := r[Bookmark1 = nil, Bookmark2 = nil];
if Result = 2 then
begin
cell1 := PPCell(Bookmark1)^;
cell2 := PPCell(Bookmark2)^;
Result := Int64(cell1^.Row) - Int64(cell2^.Row);
end;
end;
function SystemCodePageToStr(ACodePage: TSystemCodePage): String;
begin
if (ACodePage = CP_UTF8) then
Result := 'utf8'
else
if (ACodePage < 1000) or ((ACodePage >= 1250) and (ACodePage <= 1258)) then
Result := 'cp' + IntToStr(ACodePage)
else
if (ACodePage >= 28591) and (ACodePage <= 28599) then
Result := 'iso88' + IntToStr(ACodePage-28000)
else
if (ACodePage >=28600) and (ACodePage <= 28605) then
Result := 'iso88561' + IntToStr(ACodePage-28600)
else
if (ACodePage = 20866) then
Result := 'koi8r'
else
if (ACodePage = 21866) then
Result := 'koi8u'
else
Result := '';
end;
{ Copies the specified dataset to the worksheet dataset: copies fielddefs as
well as data.
Important: In order to avoid data loss in the worksheet dataset it must be
closed and FileName and SheetName must be empty; they will be set to the
values passed as parameters. }
procedure TsWorksheetDataset.CopyFromDataset(ADataset: TDataset;
const AWorkbookFileName, ASheetName: String; ASourceCodePage: TSystemCodePage = CP_UTF8);
var
i: Integer;
fsrc, fdest: TField;
stream: TMemoryStream;
bm: TBookmark;
codepageStr: String;
s: RawByteString = '';
sUTF8: UTF8String;
begin
if Active then
DatabaseError('Dataset must not be active when calling CopyFromDataset.');
if FFileName <> '' then
DatabaseError('Filename must be empty when calling CopyFromDataset.');
if FSheetName <> '' then
DatabaseError('SheetName must be empty when calling CopyFromDataset.');
codepageStr := SystemCodePageToStr(ASourceCodepage);
FFileName := AWorkbookFileName;
FSheetName := ASheetName;
Fields.Clear;
FieldDefs.Clear;
for fsrc in ADataset.Fields do
begin
AddFieldDef(fsrc.FieldName, fsrc.DataType, fsrc.Size, fsrc.FieldNo-1, CP_UTF8);
if fsrc is TAutoIncField then
begin
FAutoIncField := TAutoIncField(fsrc);
FAutoIncValue := -1;
end;
end;
CreateTable;
Open;
DisableControls;
ADataset.DisableControls;
bm := ADataset.GetBookmark;
stream := TMemoryStream.Create;
try
ADataset.Open;
ADataset.First;
while not ADataset.EoF do
begin
Append;
for i := 0 to FieldCount-1 do begin
fdest := Fields[i];
fsrc := ADataset.FieldByName(fdest.FieldName);
if not fsrc.IsNull then
case fdest.DataType of
ftString, ftFixedChar:
fdest.AsString := ConvertEncoding(fsrc.AsString, codepageStr, 'utf8');
ftWideString, ftFixedWideChar:
fdest.AsWideString := fsrc.AsWideString;
ftBoolean:
fdest.AsBoolean := fsrc.AsBoolean;
ftFloat:
fdest.AsFloat := fsrc.AsFloat;
ftCurrency:
fdest.AsCurrency := fsrc.AsCurrency;
ftInteger, ftWord, ftSmallInt {, ftShortInt}
{$IF FPC_FullVersion >= 30300}, ftByte{$IFEND}:
fdest.AsInteger := fsrc.AsInteger;
ftAutoInc:
begin
fdest.AsInteger := fsrc.AsInteger;
FAutoIncValue := Max(fdest.AsInteger, FAutoIncValue);
end;
ftLargeInt:
fdest.AsLargeInt := fsrc.AsLargeInt;
ftDate, ftTime, ftDateTime:
fdest.AsDateTime := fsrc.AsDateTime;
ftBCD, ftFmtBCD:
fdest.AsBCD := fsrc.AsBCD;
ftMemo:
begin
stream.Clear;
TBlobField(fsrc).SaveToStream(stream);
if (ASourceCodePage <> CP_UTF8) and (stream.Size > 0) then
begin
stream.Position := 0;
SetLength(s, stream.Size);
stream.Write(s[1], stream.Size);
sUTF8 := ConvertEncoding(s, codepageStr, 'utf8');
stream.Clear;
stream.Read(sUTF8[1], Length(sUTF8));
end;
stream.Position := 0;
TBlobField(fdest).LoadFromStream(stream);
end;
else
fdest.AsString := fsrc.AsString;
end;
end;
try
Post;
except
Cancel;
raise;
end;
ADataset.Next;
end;
inc(FAutoIncValue);
FModified := true;
Flush;
finally
stream.Free;
ADataset.GotoBookmark(bm);
ADataset.EnableControls;
EnableControls;
end;
end;
function TsWorksheetDataSet.CreateBlobStream(Field: TField;
Mode: TBlobStreamMode): TStream;
begin
Result := TsBlobStream.Create(Field as TBlobField, Mode);
end;
procedure TsWorksheetDataset.CreateSortParams(const FieldNames: string;
const Options: TsSortOptionsArray);
var
field_names: TStringArray;
field: TField;
i: Integer;
begin
if pos(';', FieldNames) > 0 then
field_names := FieldNames.Split(';')
else if pos(',', FieldNames) > 0 then
field_names := FieldNames.Split(',')
else
begin
SetLength(field_names, 1);
field_names[0] := FieldNames;
end;
FSortParams := InitSortParams(true, Length(field_names));
for i := 0 to High(field_names) do
begin
field := FieldByName(field_names[i]);
if not (field.DataType in (ftSupported - [ftMemo, ftWideMemo])) then
DatabaseError(Format('Type of field "%s" not supported.', [field_names[i]]));
FSortParams.Keys[i].ColRowIndex := ColIndexFromField(field);
if i < Length(Options) then
FSortParams.Keys[i].Options := Options[i];
end;
end;
{ Creates a new table, i.e. a new empty worksheet based on the given FieldDefs
The field names are written to the first row of the worksheet. }
procedure TsWorksheetDataset.CreateTable;
var
i: Integer;
fd: TsFieldDef;
begin
CheckInactive;
Clear(false); // false = do not clear FieldDefs
if FAutoIncValue < 0 then
FAutoIncValue := 1;
if FileExists(FFileName) then
exit;
FWorkbook := TsWorkbook.Create;
FWorkSheet := FWorkbook.AddWorksheet(FSheetName);
for i := 0 to FieldDefs.Count-1 do
begin
fd := FieldDefs[i] as TsFieldDef;
FWorksheet.WriteText(0, fd.ColIndex, fd.Name);
end;
if FAutoFileFormat then
FWorkbook.WriteToFile(FFileName, true)
else
FWorkbook.WriteToFile(FFileName, FFileFormat, true);
FreeAndNil(FWorkbook);
FWorksheet := nil;
FTableCreated := true;
end;
{ Automatic detection of field types and field sizes, as well as the offsets
for each field in the buffers to be used when accessing records.
Is called in case of auto-detection from a spreadsheet file (i.e. when
AutoFieldDefs is true and no other field defs have been defined. }
procedure TsWorksheetDataset.DetectFieldDefs;
var
r, c: Integer;
cLast: cardinal;
cell: PCell;
fn: String;
ft: TFieldType;
fs: Integer;
isDate, isTime: Boolean;
fmt: TsCellFormat;
numFmt: TsNumFormatParams;
begin
FieldDefs.Clear;
// Iterate through all columns and collect field defs.
cLast := FWorksheet.GetLastOccupiedColIndex;
for c := 0 to cLast do
begin
cell := FWorksheet.FindCell(FFirstRow, c);
if cell = nil then
Continue;
// Store field name from cell in FFirstRow
fn := FWorksheet.ReadAsText(cell);
// Determine field type: Iterate over rows until first data value is found.
// The cell content type determines the field type. Iteration stops then.
for r := GetFirstDataRowIndex to GetLastDataRowIndex do
begin
cell := FWorksheet.FindCell(r, c);
if (cell = nil) then
continue;
fmt := FWorkbook.GetCellFormat(FWorksheet.GetEffectiveCellFormatIndex(cell));
numFmt := FWorkbook.GetNumberFormat(fmt.NumberFormatIndex);
case cell^.ContentType of
cctNumber:
if IsCurrencyFormat(numfmt) then
ft := ftCurrency
else
if (numfmt <> nil) and (CountDecs(numfmt.NumFormatStr) > 0) then
ft := ftFloat
else
ft := ftInteger; // float will be checked further below
cctUTF8String:
ft := ftString;
cctDateTime:
ft := ftDateTime; // ftDate, ftTime will be checked below
cctBool:
ft := ftBoolean;
else
continue;
end;
break;
end;
// Determine field size and distinguish between similar field types
fs := 0;
case ft of
ftString:
if FAutoFieldDefStringSize > 0 then
fs := FAutoFieldDefStringSize
else
begin
// Find longest text in column...
for r := GetFirstDataRowIndex to GetLastDataRowIndex do
fs := Max(fs, Length(FWorksheet.ReadAsText(r, c)));
if fs > 255 then // Switch to memo when the strings are "very" long
begin
ft := ftMemo;
fs := 0;
end else
if fs > 128 then
fs := 255
else
if fs > 64 then
fs := 128
else
if fs > 32 then
fs := 64
else
if fs > 16 then
fs := 32
else
if fs > 8 then
fs := 16
else
if fs <> 1 then
fs := 8;
end;
ftInteger: // Distinguish between integer and float
for r := GetFirstDataRowIndex to GetLastDataRowIndex do
begin
cell := FWorksheet.FindCell(r, c);
if cell = nil then
continue;
if (cell^.ContentType = cctNumber) and (frac(cell^.NumberValue) <> 0) then
begin
ft := ftFloat;
break;
end;
end;
ftDateTime:
begin
// Determine whether the date/time can be simplified to a pure date or pure time.
isDate := true;
isTime := true;
for r := GetFirstDataRowIndex to GetLastDataRowIndex do
begin
cell := FWorksheet.FindCell(r, c);
if cell = nil then
continue;
if frac(cell^.DateTimeValue) <> 0 then isDate := false; // Non-integer date/time is date
if (cell^.DateTimeValue > 0) then isTime := false; // We assume that time is only between 0:00 and 23:59:59.999
if (not isDate) and (not isTime) then break;
end;
if isDate then ft := ftDate;
if isTime then ft := ftTime;
end;
else
;
end;
// Add FieldDef and set its properties
AddFieldDef(fn, ft, fs, c, CP_UTF8);
end;
// Determine the offsets at which the field data will begin in the buffer.
CalcFieldOffsets;
end;
{ Is called before the workbook is opened: checks for filename and sheet name
as well as file existence. }
procedure TsWorksheetDataset.DoBeforeOpen;
begin
if (FFileName = '') then
DatabaseError('Filename not specified.');
if (FieldDefs.Count = 0) then begin
if not FileExists(FFileName) then
DatabaseError('File not found.');
end;
inherited;
end;
// Returns the class to be used for FieldDefs. Is overridden to get access
// to the worksheet column index of a field.
class function TsWorksheetDataset.FieldDefsClass : TFieldDefsClass;
begin
Result := TsFieldDefs;
end;
{ Is called during filtering and returns true when the record who's buffer is
specified as parameter passes the filter criterions.
These are determined by the OnFilterRecord event and/or by the Filter property.
Based on TMemDataset and TBufDataset. }
function TsWorksheetDataset.FilterRecord(Buffer: TRecordBuffer): Boolean;
var
SaveState: TDatasetState;
begin
Result := True;
SaveState := SetTempState(dsFilter);
try
FFilterBuffer := Buffer;
// Check user filter
if Assigned(OnFilterRecord) then
OnFilterRecord(Self, Result);
// Check filter text
if Result and (Length(Filter) > 0) then
Result := Boolean(FParser.ExtractFromBuffer(FFilterBuffer)^);
finally
RestoreState(SaveState);
end;
end;
{ Fixes the column index in FieldDefs which is not assigned when FieldDefs are
added by code (FieldDefs.Add* is not virtual!) }
procedure TsWorksheetDataset.FixFieldDefs;
var
i: Integer;
isFirstZero: Boolean = true;
fd: TsFieldDef;
begin
for i := 0 to FieldDefs.Count-1 do
begin
fd := TsFieldDef(FieldDefs[i]);
if (fd.ColIndex = 0) then
begin
if isFirstZero then
isFirstZero := false
else
fd.ColIndex := i;
end else
if (fd.ColIndex = -1) then
fd.ColIndex := i;
end;
end;
procedure TsWorksheetDataset.Flush;
const
OVERWRITE = true;
begin
if FAutoFileFormat then
FWorkbook.WriteToFile(FFileName, OVERWRITE)
else
FWorkbook.WriteToFile(FFileName, FFileFormat, OVERWRITE);
end;
procedure TsWorksheetDataset.FreeBlobPointers(Buffer: TRecordBuffer);
var
i: Integer;
f: TField;
offset: Integer;
begin
for i := 0 to FieldCount-1 do
begin
f := Fields[i];
if f is TBlobField then
// if f.DataType in [ftMemo{, ftGraphic}] then
begin
offset := FFieldOffsets[f.FieldNo-1];
PsBlobData(Buffer + offset)^.Data := nil;
// SetLength(PsBlobData(Buffer + offset)^.Data,0);
// FillChar(PsBlobData(Buffer + offset)^, SizeOf(TsBlobData), 0);
end;
end;
end;
// Frees a record buffer.
procedure TsWorksheetDataset.FreeRecordBuffer(var Buffer: TRecordBuffer);
begin
FreeBlobPointers(Buffer);
FreeMem(Buffer);
end;
procedure TsWorksheetDataset.FreeSortParams;
begin
FSortParams.Keys := nil;
end;
procedure TsWorksheetDataset.FreeWorkbook;
begin
FreeAndNil(FWorkbook);
FWorksheet := nil;
end;
// Returns the active buffer, depending on dataset's state.
// Borrowed from TMemDataset.
function TsWorksheetDataset.GetActiveBuffer(out Buffer: TRecordBuffer): Boolean;
begin
case State of
dsEdit,
dsInsert:
Buffer := ActiveBuffer;
dsFilter:
Buffer := FFilterBuffer;
dsCalcFields:
Buffer := CalcBuffer;
else
if IsEmpty then
Buffer := nil
else
Buffer := ActiveBuffer;
end;
Result := (Buffer <> nil);
end;
{ Returns the pointer to the first cell in the row corresponding to the RecNo
to be used as a bookmark. }
function TsWorksheetDataset.GetBookmarkCellFromRecNo(ARecNo: Integer): PCell;
var
row: TRowIndex;
col: TColIndex;
begin
row := GetRowIndexFromRecNo(ARecNo);
col := FWorksheet.GetFirstColIndex;
Result := FWorksheet.GetCell(row, col);
// Do not use FindCell here because the returned cell is referenced by the
// bookmark system.
end;
// Extracts the bookmark from the specified buffer.
procedure TsWorksheetDataset.GetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
var
bookmarkCell: PCell;
begin
if Data <> nil then
begin
bookmarkCell := GetRecordInfoPtr(Buffer)^.Bookmark;
PPCell(Data)^ := bookmarkcell;
end;
end;
// Extracts the bookmark flag from the specified buffer.
function TsWorksheetDataset.GetBookmarkFlag(Buffer: TRecordBuffer): TBookmarkFlag;
begin
Result := GetRecordInfoPtr(Buffer)^.BookmarkFlag;
end;
// Determines worksheet row index for the current record.
function TsWorksheetDataset.GetCurrentRowIndex: TRowIndex;
begin
Result := GetFirstDataRowIndex + FRecNo;
end;
{ Extracts the data value of a specific field from the active buffer and copies
it to the memory to which Buffer points.
Returns false when nothing is copied.
Adapted from TMemDataset. }
function TsWorksheetDataset.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
var
srcBuffer: TRecordBuffer;
idx: Integer;
dt: TDateTime = 0;
{%H-}dtr: TDateTimeRec;
begin
Result := GetActiveBuffer(srcBuffer);
if not Result then
exit;
idx := Field.FieldNo - 1;
if idx >= 0 then
begin
Result := not GetFieldIsNull(GetNullMaskPtr(srcBuffer), Field.FieldNo);
if not Result then
begin
if Field = FAutoIncField then
Move(FAutoIncValue, Buffer^, Field.DataSize);
exit;
end;
if Assigned(Buffer) then
begin
inc(srcBuffer, FFieldOffsets[idx]);
if (Field.DataType in [ftDate, ftTime, ftDateTime]) then
begin
// The srcBuffer contains date/time values as TDateTime, but the
// field expects them to be TDateTimeRec --> convert to TDateTimeRec
Move(srcBuffer^, dt, SizeOf(TDateTime));
dtr := DateTimeToDateTimeRec(Field.DataType, dt);
Move(dtr, Buffer^, SizeOf(TDateTimeRec));
end else
// No need to handle BLOB fields here because they always have Buffer=nil
Move(srcBuffer^, Buffer^, Field.DataSize);
end;
end else
begin // Calculated, Lookup
inc(srcBuffer, RecordSize + Field.Offset);
Result := Boolean(SrcBuffer[0]);
if Result and Assigned(Buffer) then
Move(srcBuffer[1], Buffer^, Field.DataSize);
end;
end;
// Returns the worksheet row index of the record. This is the row
// following the first worksheet row because that is reserved for the column
// titles (field names).
function TsWorksheetDataset.GetFirstDataRowIndex: TRowIndex;
begin
Result := FFirstRow + 1; // +1 because the first row contains the column titles.
end;
// Returns the worksheet row index of the record.
function TsWorksheetDataset.GetLastDataRowIndex: TRowIndex;
begin
Result := FLastRow;
end;
{ Calculates the pointer to the position of the null mask in the buffer.
The null mask is after the data block. }
function TsWorksheetDataset.GetNullMaskPtr(Buffer: TRecordBuffer): Pointer;
begin
Result := Buffer;
inc(Result, GetTotalFieldSize);
end;
// The information whether a field is NULL is stored in the bits of the
// "Null mask". Each bit corresponds to a field.
// Calculates the size of the null mask.
function TsWorksheetDataset.GetNullMaskSize: Integer;
var
n: Integer;
begin
n := FieldDefs.Count;
Result := n div 8 + 1;
end;
// Returns the number of the current record.
function TsWorksheetDataset.GetRecNo: LongInt;
begin
UpdateCursorPos;
if (FRecNo < 0) or (RecordCount = 0) or (State = dsInsert) then
Result := 0
else
Result := FRecNo + 1;
end;
function TsWorksheetDataset.GetRecord(Buffer: TRecordBuffer;
GetMode: TGetMode; DoCheck: Boolean): TGetResult;
var
accepted: Boolean;
begin
Result := grOK;
accepted := false;
if RecordCount < 1 then
begin
Result := grEOF;
exit;
end;
repeat
case GetMode of
gmCurrent:
if (FRecNo >= RecordCount) or (FRecNo < 0) then
Result := grError;
gmNext:
if (FRecNo < RecordCount - 1) then
inc(FRecNo)
else
Result := grEOF;
gmPrior:
if (FRecNo > 0) then
dec(FRecNo)
else
Result := grBOF;
end;
// Load the data
if Result = grOK then
begin
LoadWorksheetToBuffer(Buffer, FRecNo);
with GetRecordInfoPtr(Buffer)^ do
begin
Bookmark := GetBookmarkCellFromRecNo(FRecNo);
BookmarkFlag := bfCurrent;
end;
GetCalcFields(Buffer);
if Filtered then
accepted := FilterRecord(Buffer) // Filtering
else
accepted := true;
if (GetMode = gmCurrent) and not accepted then
Result := grError;
end;
until (Result <> grOK) or accepted;
if (Result = grError) and DoCheck then
DatabaseError('[GetRecord] Invalid record.');
end;
function TsWorksheetDataset.GetRecordCount: LongInt;
begin
//CheckActive;
if FRecordCount = -1 then
FRecordCount := GetLastDataRowIndex - GetFirstDataRowIndex + 1;
Result := FRecordCount;
end;
// Returns a pointer to the bookmark block inside the given buffer.
function TsWorksheetDataset.GetRecordInfoPtr(Buffer: TRecordBuffer): PsRecordInfo;
begin
Result := PsRecordInfo(Buffer + GetTotalFieldSize + GetNullMaskSize);
end;
{ Determines the size of the full record buffer:
- data block: a contiguous field of bytes consisting of the field values
- null mask: a bit mask storing the information that a field is null
- Record Info: the bookmark part of the record }
function TsWorksheetDataset.GetRecordSize: Word;
begin
if FRecordBufferSize = -1 then
FRecordBufferSize := GetTotalFieldSize + GetNullMaskSize + SizeOf(TsRecordInfo);
Result := FRecordBufferSize;
end;
function TsWorksheetDataset.GetRowIndexFromRecNo(ARecNo: Integer): TRowIndex;
begin
Result := GetFirstDataRowIndex + ARecNo;
end;
// Returns the size of the data part in a buffer. This is the sume of all
// field sizes.
function TsWorksheetDataset.GetTotalFieldSize: Integer;
var
f: TField;
begin
if FTotalFieldSize = -1 then
begin
FTotalFieldSize := 0;
for f in Fields do
if f is TBlobField then
// Blob fields have zero DataSize, but they occupy space in the record buffer.
FTotalFieldSize := FTotalFieldSize + SizeOf(TsBlobData)
else
FTotalFieldSize := FTotalFieldSize + f.DataSize;
end;
Result := FTotalFieldSize;
end;
{ Called internally when a record is added. }
procedure TsWorksheetDataset.InternalAddRecord(Buffer: Pointer; DoAppend: Boolean);
var
row: TRowIndex;
begin
inc(FLastRow);
inc(FRecordCount);
if DoAppend then
begin
row := FLastRow;
SetCurrentRow(row);
end;
WriteBufferToWorksheet(Buffer);
FModified := true;
end;
{ Closes the dataset }
procedure TsWorksheetDataset.InternalClose;
begin
FIsOpen := false;
if FModified then begin
Flush;
FModified := false;
end;
FreeWorkbook;
if FAutoIncValue > -1 then FAUtoIncValue := 1;
FreeAndNil(FParser);
if DefaultFields then
DestroyFields;
FTotalFieldSize := -1;
FRecordBufferSize := -1;
FRecNo := -1;
end;
{ Called internally when a record is deleted.
Must delete the row from the worksheet. }
procedure TsWorksheetDataset.InternalDelete;
var
row: TRowIndex;
begin
if (FRecNo <0) or (FRecNo >= GetRecordCount) then
exit;
row := GetRowIndexFromRecNo(FRecNo);
FWorksheet.DeleteRow(row);
dec(FRecordCount);
if FRecordCount = 0 then
FRecNo := -1
else
if FRecNo >= FRecordCount then FRecNo := FRecordCount - 1;
FModified := true;
end;
{ Moves the cursor to the first record, i.e. the first data row in the worksheet.}
procedure TsWorksheetDataset.InternalFirst;
begin
FRecNo := -1;
end;
{ Internally, a bookmark is a cell in a worksheet row. }
procedure TsWorksheetDataset.InternalGotoBookmark(ABookmark: Pointer);
var
bookmarkCell: PCell;
begin
bookmarkCell := PPCell(ABookmark)^;
if (bookmarkCell <> nil) and (bookmarkCell^.Row >= GetFirstDataRowIndex) and
(bookmarkCell^.Row <= GetLastDataRowIndex)
then
SetCurrentRow(bookmarkCell^.Row)
else
DatabaseError('Bookmark not found.');
end;
{ Initializes the field defs. }
procedure TsWorksheetDataset.InternalInitFieldDefs;
begin
FixFieldDefs;
if FAutoFieldDefs and (FieldDefs.Count = 0) then
DetectFieldDefs;
CalcFieldOffsets;
end;
{ Moves the cursor to the last record, the last data row of the worksheet }
procedure TsWorksheetDataset.InternalLast;
begin
FRecNo := RecordCount;
end;
{ Opens the dataset: Opens the workbook, initializes field defs, creates fields }
procedure TsWorksheetDataset.InternalOpen;
begin
FWorkbook := TsWorkbook.Create;
try
if (FSheetName <> '') and (not FWorkbook.ValidWorksheetName(FSheetName)) then
DatabaseError('"' + FSheetName + '" is not a valid worksheet name.');
if not FileExists(FFileName) and (not FAutoFieldDefs) and (not FTableCreated) then
begin
if FSheetName = '' then
DatabaseError('Worksheet name not specified.');
FWorkSheet := FWorkbook.AddWorksheet(FSheetName);
CreateTable;
end else
begin
if FAutoFileFormat then
FWorkbook.ReadFromFile(FFileName)
else
FWorkbook.ReadFromFile(FFileName, FFileFormat);
if FSheetName = '' then
begin
FWorksheet := FWorkbook.GetFirstWorksheet;
if not (csDesigning in ComponentState) then
FSheetName := FWorksheet.Name;
end
else
FWorksheet := FWorkbook.GetWorksheetByName(FSheetName);
if FWorksheet = nil then
DatabaseError('Worksheet not found.');
end;
FLastCol := FWorksheet.GetLastColIndex(true);
FFirstRow := FWorksheet.GetFirstRowIndex(true);
FLastRow := FWorksheet.GetLastOccupiedRowIndex;
FRecordCount := -1;
FTotalFieldSize := -1;
FRecordBufferSize := -1;
InternalInitFieldDefs;
if DefaultFields then
CreateFields;
BindFields(True); // Computes CalcFieldsSize
GetTotalFieldSize;
GetRecordSize;
FRecNo := -1;
SetupAutoInc;
FModified := false;
FIsOpen := true;
except
on E: Exception do
begin
FreeWorkbook;
DatabaseError('Error opening workbook: ' + E.Message);
end;
end;
end;
{ Called inernally when a record is posted. }
procedure TsWorksheetDataset.InternalPost;
begin
CheckActive;
if not (State in [dsEdit, dsInsert]) then
Exit;
inherited InternalPost;
if (State=dsEdit) then
WriteBufferToWorksheet(ActiveBuffer)
else
begin
if Assigned(FAutoIncField) then
begin
FAutoIncField.AsInteger := FAutoIncValue;
inc(FAutoIncValue);
end;
InternalAddRecord(ActiveBuffer, True);
end;
end;
{ Reinitializes a buffer which has been allocated previously
-> zero out everything
In this step the NullMask is erased, and this means that all fields are null.
We cannot just fill the buffer with 0s since that would overwrite our BLOB
pointers. Therefore we free the blob pointers first, then fill the buffer
with zeros, then reallocate the blob pointers }
procedure TsWorksheetDataset.InternalInitRecord(Buffer: TRecordBuffer);
begin
FreeBlobPointers(Buffer);
FillChar(Buffer^, FRecordBufferSize, 0);
AllocBlobPointers(Buffer);
end;
{ Sets the database cursor to the record specified by the given buffer. We
extract here the bookmark associated with the buffer and go to this bookmark. }
procedure TsWorksheetDataset.InternalSetToRecord(Buffer: TRecordBuffer);
var
bookmarkCell: PCell;
begin
bookmarkCell := GetRecordInfoPtr(Buffer)^.Bookmark;
InternalGotoBookmark(@bookmarkCell);
end;
function TsWorksheetDataset.IsCursorOpen: boolean;
begin
Result := FIsOpen;
end;
{ Reads the cells data of the current worksheet row and
copies them to the buffer. }
procedure TsWorksheetDataset.LoadWorksheetToBuffer(Buffer: TRecordBuffer;
ARecNo: Integer);
var
field: TField;
row: TRowIndex;
col: TColIndex;
cell: PCell;
s: String;
ws: WideString;
{%H-}i: Integer;
{%H-}si: SmallInt;
{%H-}b: Byte;
{%H-}w: word;
{%H-}li: LargeInt;
{%H-}wb: WordBool;
{%H-}c: Currency;
{%H-}bcd: TBCD;
nullMask: Pointer;
maxLen: Integer;
fs: Integer;
begin
nullMask := GetNullMaskPtr(Buffer);
row := GetRowIndexFromRecNo(ARecNo);
for field in Fields do
begin
col := ColIndexFromField(field);
if col = -1 then // this happens for calculated fields.
continue;
// Find the cell at the column and row. BUT: For bookmark support, we need
// a cell even when there is none. So: Find the cell by calling GetCell
// which adds a blank cell in such a case.
cell := FWorksheet.GetCell(row, col);
ClearFieldIsNull(nullMask, field.FieldNo);
if field is TBlobField then
// BLOB fields have zero DataSize although they occupy space in the buffer
fs := SizeOf(TsBlobData)
else
fs := field.DataSize;
case cell^.ContentType of
cctUTF8String:
begin
s := FWorksheet.ReadAsText(cell);
if s = '' then
SetFieldIsNull(nullMask, field.FieldNo)
else
if field.DataType = ftMemo then
begin
with PsBlobData(Buffer)^ do
begin
SetLength(Data, Length(s));
Move(s[1], Data[0], Length(s));
end;
end else
if field.DataType in [ftWideString, ftFixedWideChar] then
begin
maxLen := field.Size;
ws := UTF8ToUTF16(s);
ws := UTF16Copy(ws, 1, maxLen) + #0#0;
Move(ws[1], Buffer^, Length(ws)*2);
end else
begin
maxLen := field.Size;
s := UTF8Copy(s, 1, maxLen) + #0;
Move(s[1], Buffer^, Length(s));
end;
end;
cctNumber:
case field.DataType of
ftFloat, ftCurrency:
Move(cell^.NumberValue, Buffer^, SizeOf(cell^.NumberValue));
ftBCD:
begin
c := cell^.NumberValue;
Move(c, Buffer^, SizeOf(Currency));
end;
ftFmtBCD:
begin
c := cell^.NumberValue;
bcd := CurrToBCD(c);
Move(bcd, Buffer^, SizeOf(TBCD));
end;
ftInteger, ftAutoInc:
begin
i := Round(cell^.NumberValue);
Move(i, Buffer^, SizeOf(i));
if field.DataType = ftAutoInc then
FAutoIncField := TAutoIncField(field);
end;
{$IF FPC_FullVersion >= 30300}
ftByte:
begin
b := byte(round(cell^.NumberValue));
Move(b, Buffer^, SizeOf(b));
end;
{$IFEND}
ftSmallInt:
begin
si := SmallInt(round(cell^.NumberValue));
Move(si, Buffer^, SizeOf(si));
end;
ftWord:
begin
w := word(round(cell^.NumberValue));
Move(w, Buffer^, SizeOf(w));
end;
ftLargeInt:
begin
li := LargeInt(round(cell^.NumberValue));
Move(li, Buffer^, SizeOf(li));
end;
ftString, ftFixedChar:
begin
s := FWorksheet.ReadAsText(cell) + #0;
Move(s[1], Buffer^, Length(s));
end;
else
;
end;
cctDateTime:
// TDataset handles date/time value as TDateTimeRec but expects them
// to be TDateTime in the buffer. How strange!
Move(cell^.DateTimeValue, Buffer^, SizeOf(TDateTime));
cctBool:
begin
wb := cell^.BoolValue; // Boolean field stores value as wordbool
Move(wb, Buffer^, SizeOf(wb));
end;
cctEmpty:
SetFieldIsNull(nullMask, field.FieldNo);
else
;
end;
inc(Buffer, fs);
end;
end;
{ Searches the first record for which the fields specified by Keyfields
(semicolon-separated list) have the values defined in KeyValues.
Returns false, when no such record is found.
Code from TMemDataset. }
function TsWorksheetDataset.Locate(const KeyFields: string;
const KeyValues: Variant; Options: TLocateOptions): boolean;
var
ARecNo: integer;
begin
// Call inherited to make sure the dataset is bi-directional
Result := inherited;
CheckActive;
Result := LocateRecord(KeyFields, KeyValues, Options, ARecNo);
if Result then begin
// TODO: generate scroll events if matched record is found
FRecNo := ARecNo;
Resync([]);
end;
end;
{ Helper function for locating records.
Taken from TMemDataset: This implements a simple search from record to record.
To do: introduce an index for faster searching. }
function TsWorksheetDataset.LocateRecord(
const KeyFields: string;
const KeyValues: Variant; Options: TLocateOptions;
out ARecNo: integer): Boolean;
var
SaveState: TDataSetState;
lKeyFields: TList;
Matched: boolean;
AKeyValues: variant;
i: integer;
field: TField;
s1,s2: String;
ws1, ws2: WideString;
begin
Result := false;
SaveState := SetTempState(dsFilter);
FFilterBuffer := TempBuffer;
lKeyFields := TList.Create;
try
GetFieldList(lKeyFields, KeyFields);
if VarArrayDimCount(KeyValues) = 0 then
begin
Matched := lKeyFields.Count = 1;
AKeyValues := VarArrayOf([KeyValues]);
end else
if VarArrayDimCount(KeyValues) = 1 then
begin
Matched := VarArrayHighBound(KeyValues,1) + 1 = lKeyFields.Count;
AKeyValues := KeyValues;
end
else
Matched := false;
if Matched then
begin
ARecNo := 0;
while ARecNo < RecordCount do
begin
LoadWorksheetToBuffer(FFilterBuffer, ARecNo);
if Filtered then
Result := FilterRecord(FFilterBuffer)
else
Result := true;
// compare field by field
i := 0;
while Result and (i < lKeyFields.Count) do
begin
field := TField(lKeyFields[i]);
// string fields
if field.DataType in [ftString, ftFixedChar] then
begin
{$IF FPC_FullVersion >= 30200}
if TStringField(field).CodePage=CP_UTF8 then
begin
s1 := field.AsUTF8String;
s2 := UTF8Encode(VarToUnicodeStr(AKeyValues[i]));
end else
{$IFEND}
begin
s1 := field.AsString;
s2 := VarToStr(AKeyValues[i]);
end;
if loPartialKey in Options then
s1 := copy(s1, 1, length(s2));
if loCaseInsensitive in Options then
Result := AnsiCompareText(s1, s2)=0
else
Result := s1=s2;
end else
// widestring fields
if field.DataType in [ftWideString, ftFixedWideChar] then
begin
ws1 := field.AsWideString;
ws2 := VarToWideStr(AKeyValues[i]);
if loPartialKey in Options then
ws1 := UTF16Copy(ws1, 1, Length(ws2));
if loCaseInsensitive in Options then
Result := WideCompareText(ws1, ws2) = 0
else
Result := ws1 = ws2;
end
// all other fields
else
Result := (field.Value=AKeyValues[i]);
inc(i);
end;
if Result then
break;
inc(ARecNo);
end;
end;
finally
lKeyFields.Free;
RestoreState(SaveState);
end;
end;
{ Searches the first record for which the fields specified by KeyFields
(semicolon-separated list of field names) have the values defined in KeyValues.
Returns the field values of the ResultFields (a semicolon-separated list of field
names), or NULL if there is no match.
Code from TMemDataset. }
function TsWorksheetDataset.Lookup(const KeyFields: string; const KeyValues: Variant;
const ResultFields: string): Variant;
var
ARecNo: integer;
SaveState: TDataSetState;
begin
if LocateRecord(KeyFields, KeyValues, [], ARecNo) then
begin
SaveState := SetTempState(dsCalcFields);
try
// FFilterBuffer contains found record
CalculateFields(FFilterBuffer); // CalcBuffer is set to FFilterBuffer
Result := FieldValues[ResultFields];
finally
RestoreState(SaveState);
end;
end
else
Result := Null;
end;
// from TBufDataset
procedure TsWorksheetDataset.ParseFilter(const AFilter: string);
begin
// parser created?
if Length(AFilter) > 0 then
begin
if (FParser = nil) and IsCursorOpen then
FParser := TBufDatasetParser.Create(Self);
// is there a parser now?
if FParser <> nil then
begin
// set options
FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
// parse expression
FParser.ParseExpression(AFilter);
end;
end;
end;
procedure TsWorksheetDataset.SetAutoFieldDefStringSize(Value: Integer);
begin
if FAutoFieldDefStringSize = Value then
exit;
CheckInactive;
FAutoFieldDefStringSize := Value;
end;
procedure TsWorksheetDataset.SetBookmarkData(Buffer: TRecordBuffer; Data: Pointer);
begin
if Data <> nil then
GetRecordInfoPtr(Buffer)^.Bookmark := PPCell(Data)^
else
GetRecordInfoPtr(Buffer)^.Bookmark := nil;
end;
procedure TsWorksheetDataset.SetBookmarkFlag(Buffer: TRecordBuffer;
Value: TBookmarkFlag);
begin
GetRecordInfoPtr(Buffer)^.BookmarkFlag := Value;
end;
procedure TsWorksheetDataset.SetCurrentRow(ARow: TRowIndex);
begin
FRecNo := ARow - GetFirstDataRowIndex;
end;
{ Copies the data to which Buffer points to the position in the active buffer
which belongs to the specified field.
Adapted from TMemDataset. }
procedure TsWorksheetDataset.SetFieldData(Field: TField; Buffer: Pointer);
var
destBuffer: TRecordBuffer;
idx: Integer;
{%H-}dt: TDateTime;
dtr: TDateTimeRec;
s: String;
ws: widestring;
L: Integer;
begin
if not GetActiveBuffer(destBuffer) then
exit;
idx := Field.FieldNo - 1;
if idx >= 0 then
begin
if State in [dsEdit, dsInsert, dsNewValue] then
Field.Validate(Buffer);
if Buffer = nil then
SetFieldIsNull(GetNullMaskPtr(destBuffer), Field.FieldNo)
else
begin
ClearFieldIsNull(GetNullMaskPtr(destBuffer), Field.FieldNo);
inc(destBuffer, FFieldOffsets[idx]);
if Field.DataType in [ftDate, ftTime, ftDateTime] then
begin
// Special treatment for date/time values: TDataset expects them
// to be TDateTime in the destBuffer, but to be TDateTimeRec in the
// input Buffer.
dtr := Default(TDateTimeRec);
Move(Buffer^, dtr, SizeOf(dtr));
dt := DateTimeRecToDateTime(Field.DataType, dtr);
Move(dt, destBuffer^, SizeOf(dt));
end else
if Field.DataType in [ftString, ftFixedChar] then
begin
FillChar(destBuffer^, Field.DataSize, 0);
// Truncate strings which have more characters than efined by Field.Size.
// This should have been done by the calling routine, but it considers
// only Field.Datasize.
s := StrPas(PAnsiChar(Buffer));
{$IF FPC_FullVersion >= 30200};
if (TStringField(Field).CodePage = CP_UTF8) then
begin
L := UTF8Length(s);
if L > Field.Size then
s := UTF8Copy(s, 1, Field.Size);
Move(s[1], destBuffer^, Length(s));
end else
{$IFEND}
begin
L := Length(s);
if L > Field.Size then
s := Copy(s, 1, Field.Size);
Move(s[1], destBuffer^, Length(s))
end;
end else
if Field.DataType in [ftWideString, ftFixedWideChar] then
begin
// Truncate strings which have more characters than defined by Field.Size.
// This should have been done by the calling routine, but it considers
// only Field.Datasize.
FillChar(destBuffer^, Field.Size*2, 0);
ws := StrPas(PWideChar(Buffer));
if Length(ws) > Field.Size then
ws := UTF16Copy(ws, 1, Field.Size);
Move(ws[1], destBuffer^, Length(ws)*2);
end else
Move(Buffer^, destBuffer^, Field.DataSize);
end;
end else
begin // Calculated, Lookup
inc(destBuffer, RecordSize + Field.Offset);
Boolean(destBuffer[0]) := Buffer <> nil;
if Assigned(Buffer) then
Move(Buffer^, DestBuffer[1], Field.DataSize);
end;
if not (State in [dsCalcFields, dsFilter, dsNewValue]) then
DataEvent(deFieldChange, PtrInt(Field));
end;
// From TBufDataset
procedure TsWorksheetDataset.SetFiltered(Value: Boolean);
begin
if Value = Filtered then
exit;
// Pass on to ancestor
inherited;
// Only refresh if active
if IsCursorOpen then
Resync([]);
end;
// From TBufDataset
procedure TsWorksheetDataset.SetFilterText(const Value: string);
begin
if Value = Filter then
exit;
// Parse
ParseFilter(Value);
// Call dataset method
inherited;
// Refilter dataset if filtered
if IsCursorOpen and Filtered then Resync([]);
end;
procedure TsWorksheetDataset.SetRecNo(Value: Integer);
begin
CheckBrowseMode;
if (Value >= 1) and (Value <= RecordCount) then
begin
FRecNo := Value-1;
Resync([]);
end;
end;
{ Finds the field declared as AutoInc field.
Determines the starting value of the AutoInc counter by looking for the max
value in the AutoInc column. }
procedure TsWorksheetDataset.SetupAutoInc;
var
f: TField;
c: TColIndex;
r: Integer;
mx: Integer;
cell: PCell;
begin
FAutoIncField := nil;
FAutoIncValue := -1;
for f in Fields do
if f is TAutoIncField then
begin
FAutoIncField := TAutoIncField(f);
break;
end;
// No AutoInc field found among FieldDefs.
if FAutoIncField = nil then
exit;
// Search for the maximum value in the autoinc column.
// Take care of blank and non-numeric cells - this should not happen but
// the spreadsheet file can be opened outside the db-aware application
// and modified there.
mx := -MaxInt;
c := ColIndexFromField(f);
r := GetFirstDataRowIndex;
for r := GetFirstDataRowIndex to FLastRow do
begin
cell := FWorksheet.FindCell(r, c);
if cell <> nil then
begin
case cell^.ContentType of
cctNumber: mx := Max(mx, round(FWorksheet.ReadAsNumber(cell)));
cctEmpty: ;
else DatabaseError('AutoInc field must be a assigned to numeric cells.');
end;
end;
end;
if mx = -MaxInt then
FAutoIncvalue := 1
else
FAutoIncValue := mx + 1;
end;
procedure TsWorksheetDataset.Sort;
const
firstCol = 0;
begin
FWorksheet.Sort(FSortParams, GetFirstDataRowIndex, firstCol, GetLastDataRowIndex, FLastCol);
end;
procedure TsWorksheetDataset.SortOnField(const FieldName: String);
begin
SortOnField(FieldName, []);
end;
procedure TsWorksheetDataset.SortOnField(const FieldName: String;
const Options: TsSortOptions);
var
bm: TBookmark;
optns: TsSortOptionsArray = nil;
begin
bm := GetBookmark;
try
DisableControls;
try
SetLength(optns, 1);
optns[0] := Options;
CreateSortParams(FieldName, optns);
Sort;
FModified := true;
finally
EnableControls;
end;
finally
GotoBookmark(bm);
FreeBookmark(bm);
end;
Resync([]);
end;
procedure TsWorksheetDataset.SortOnFields(const FieldNames: String);
begin
SortOnFields(FieldNames, nil);
end;
procedure TsWorksheetDataset.SortOnFields(const FieldNames: string;
const Options: TsSortOptionsArray);
var
bm: TBookmark;
begin
bm := GetBookmark;
try
DisableControls;
try
CreateSortParams(FieldNames, Options);
Sort;
FModified := true;
finally
EnableControls;
end;
GotoBookmark(bm);
finally
FreeBookmark(bm);
end;
Resync([]);
end;
{ Writes the buffer back to the worksheet. }
procedure TsWorksheetDataset.WriteBufferToWorksheet(Buffer: TRecordBuffer);
var
row: TRowIndex;
col: TColIndex;
cell: PCell;
field: TField;
P: Pointer;
s: String = '';
ws: WideString = '';
curr: Currency = 0;
begin
row := GetCurrentRowIndex;
P := Buffer;
for field in Fields do begin
col := ColIndexFromField(field);
cell := FWorksheet.FindCell(row, col);
if GetFieldIsNull(GetNullMaskPtr(Buffer), field.FieldNo) then
FWorksheet.WriteBlank(cell)
else
begin
P := Buffer + FFieldOffsets[field.FieldNo-1];
cell := FWorksheet.GetCell(row, col);
case field.DataType of
ftFloat:
if (TFloatField(field).Precision >= 15) or (TFloatField(field).Precision < 0) then
FWorksheet.WriteNumber(cell, PDouble(P)^, nfGeneral)
else
FWorksheet.WriteNumber(cell, PDouble(P)^, nfFixed, TFloatField(field).Precision);
ftCurrency:
FWorksheet.WriteCurrency(cell, PDouble(P)^, nfCurrency, 2);
ftBCD:
FWorksheet.WriteNumber(cell, PCurrency(P)^, nfFixed, TBCDField(field).Size);
ftFmtBCD:
if BCDToCurr(PBCD(P)^, curr) then
FWorksheet.WriteNumber(cell, curr, nfFixed, TFmtBCDField(field).Size);
ftInteger, ftAutoInc:
FWorksheet.WriteNumber(cell, PInteger(P)^);
{$IF FPC_FullVersion >= 30300}
ftByte:
FWorksheet.WriteNumber(cell, PByte(P)^);
{$IFEND}
ftSmallInt:
FWorksheet.WriteNumber(cell, PSmallInt(P)^);
ftWord:
FWorksheet.WriteNumber(cell, PWord(P)^);
ftLargeInt:
FWorksheet.WriteNumber(cell, PLargeInt(P)^);
ftDateTime:
FWorksheet.WriteDateTime(cell, PDateTime(P)^, nfShortDateTime);
ftDate:
FWorksheet.WriteDateTime(Cell, PDateTime(P)^, nfShortDate);
ftTime:
FWorksheet.WriteDateTime(cell, PDateTime(P)^, nfLongTime);
ftBoolean:
FWorksheet.WriteBoolValue(cell, PWordBool(P)^);
ftString, ftFixedChar:
FWorksheet.WriteText(cell, StrPas(PChar(P)));
ftWideString, ftFixedWideChar:
begin
Setlength(ws, StrLen(PWideChar(P)));
Move(P^, ws[1], Length(ws)*2);
s := UTF16ToUTF8(ws);
FWorksheet.WriteText(cell, s);
end;
ftMemo:
begin
SetLength(s, Length(PsBlobData(P)^.Data));
if Length(PsBlobData(P)^.Data) > 0 then
Move(PsBlobData(P)^.Data[0], s[1], Length(s));
FWorksheet.WriteText(cell, s);
end;
else
;
end;
end;
end;
FModified := true;
end;
procedure Register;
begin
RegisterComponents('Data Access', [
TsWorksheetDataset
]);
end;
end.
Reference in New Issue View Git Blame Copy Permalink