7030 lines
157 KiB
ObjectPascal
7030 lines
157 KiB
ObjectPascal
|
||
{******************************************}
|
||
{ }
|
||
{ FastReport VCL }
|
||
{ BIFF8 Writing API }
|
||
{ }
|
||
{ Copyright (c) 1998-2021 }
|
||
{ by Fast Reports Inc. }
|
||
{ }
|
||
{******************************************}
|
||
|
||
{ This module provides API for writing BIFF
|
||
streams. This format is documented in
|
||
MSDN [MS-XLS] section.
|
||
|
||
The only way to store BIFF2-BIFF4 documents is
|
||
to write data to a simple stream file. Since BIFF5
|
||
the documents can be stored as compound document files:
|
||
see frxCBFF.pas }
|
||
|
||
unit frxBIFF;
|
||
|
||
interface
|
||
|
||
{$I frx.inc}
|
||
|
||
uses
|
||
Windows,
|
||
Graphics,
|
||
SysUtils,
|
||
Classes,
|
||
Contnrs,
|
||
frxUtils,
|
||
frxStorage,
|
||
frxEscher,
|
||
frxCrypto
|
||
{$IFDEF DELPHI16}
|
||
, System.UITypes
|
||
{$ENDIF}
|
||
;
|
||
|
||
type
|
||
TBiffPaperSize = Word;
|
||
TBiffFormatIndex = LongInt;
|
||
TBiffStreamKind = LongInt; // See bk*** values
|
||
TBiffRecId = Word; // BiffId*** values
|
||
|
||
const
|
||
|
||
{ BIFF8 allows the maximium record
|
||
length of 8228 bytes including the record
|
||
header (4 bytes) }
|
||
|
||
BiffMaxRecLen = $2020;
|
||
|
||
{ The maximum number of blocks in a MERGEDCELLS record.
|
||
Required by [MS-XLS] 2.4.168 }
|
||
|
||
BiffMaxMrgCellsNum = 1026;
|
||
|
||
//
|
||
// Rows in BIFF8 are grouped into blocks.
|
||
//
|
||
|
||
BiffRowBlockSz = 32;
|
||
|
||
//
|
||
// BIFF8 palette size.
|
||
// This size includes the first 8 built-in colors.
|
||
//
|
||
|
||
BiffPaletteSize = $40;
|
||
|
||
{ RRD table contains unique identifiers
|
||
for all sheets in a workbook. If the
|
||
count of sheets is greater that BiffRrdMaxCount
|
||
then the RRD table is not emitted. }
|
||
|
||
BiffRrdMaxCount = $1010;
|
||
|
||
//
|
||
// BIFF8 allows cells with coordinates within
|
||
// the following bounds:
|
||
//
|
||
// row = 0 .. BiffMaxRow
|
||
// col = 0 .. BiffMaxCol
|
||
//
|
||
|
||
BiffMaxRow = $fffe;
|
||
BiffMaxCol = $fe;
|
||
|
||
//
|
||
// Number formats are stored in a table.
|
||
// The first 164 items are reserved and
|
||
// define special widely used formats.
|
||
// The first user format can begin from 164.
|
||
//
|
||
|
||
BiffUserFormat = 164;
|
||
|
||
//
|
||
// BOF records have a field which specifies
|
||
// a type of a stream which they start.
|
||
// TBiffStreamKind lists all possible stream types.
|
||
//
|
||
|
||
bkWBGlobals = 5;
|
||
bkVBModule = 6;
|
||
bkSheet = $10;
|
||
bkChart = $20;
|
||
bkMacro = $40;
|
||
bkWorkspace = $100;
|
||
|
||
//
|
||
// Font options
|
||
//
|
||
|
||
foBold = $1;
|
||
foItalic = $2;
|
||
foUnderline = $4;
|
||
foStruckOut = $8;
|
||
foOutline = $10;
|
||
foShadow = $20;
|
||
foCondense = $40;
|
||
foExtended = $80;
|
||
|
||
//
|
||
// Font underline values
|
||
//
|
||
|
||
fuNone = 0;
|
||
fuSingle = 1;
|
||
fuDouble = 2;
|
||
fuSingleAcc = $21;
|
||
fuDoubleAcc = $22;
|
||
|
||
//
|
||
// Normally, font weight value lies
|
||
// in range 100..1000
|
||
//
|
||
|
||
fwNormal = 400;
|
||
fwBold = 700;
|
||
|
||
//
|
||
// XF cell protection
|
||
//
|
||
|
||
xftpCellLocked = $1;
|
||
xftpHidden = $2;
|
||
xftpStyle = $4;
|
||
|
||
//
|
||
// XF used attributes flags
|
||
//
|
||
|
||
BiffXfuaNumber = $01;
|
||
BiffXfuaFont = $02;
|
||
BiffXfuaText = $04;
|
||
BiffXfuaBorders = $08;
|
||
BiffXfuaBg = $10;
|
||
BiffXfuaCellProt = $20;
|
||
BiffXfuaAll = $3f;
|
||
|
||
//
|
||
// Pattern style
|
||
//
|
||
|
||
psNone = 0;
|
||
psSolid = 1;
|
||
psChess = 2;
|
||
psHorThick = 5;
|
||
psVerThick = 6;
|
||
psChessThick = 9;
|
||
psHor = $B;
|
||
psVer = $C;
|
||
psDiagBack = $D;
|
||
psDiag = $E;
|
||
psCross = $F;
|
||
psCrossDiag = $10;
|
||
|
||
//
|
||
// Window options
|
||
//
|
||
|
||
woFormula = $1;
|
||
woGrid = $2;
|
||
woHeaders = $4;
|
||
woFreezePanes = $8;
|
||
woShowZeros = $10;
|
||
woAutoGridCol = $20;
|
||
woColRTL = $40;
|
||
woOutline = $80;
|
||
woNoSplits = $100;
|
||
woSelected = $200;
|
||
woActive = $400;
|
||
woPageBreak = $800;
|
||
|
||
//
|
||
// Sheet type
|
||
//
|
||
|
||
skWorksheet = 0;
|
||
skChart = 2;
|
||
skVB = 6;
|
||
|
||
//
|
||
// BIFF keeps all format strings in a single list.
|
||
// Several entries in this list are reserved.
|
||
// A few indexes to these reserved formats are listed here.
|
||
//
|
||
|
||
BiffFmtGeneral = 0;
|
||
BiffFmtFixedPoint = 2; // 0.00
|
||
BiffFmtThSep = 4; // #,##0.00
|
||
BiffFmtCurrency = 5; // "$"#,##0_);("$"#,##0)
|
||
BiffFmtDateTime = 22;//32; // M/D/YY h:mm
|
||
|
||
//
|
||
// Flags for options of WINDOW2 object
|
||
//
|
||
|
||
BiffWoFormulas = 1; // show formulas; clear = show results of formulas
|
||
BiffWoGridLines = 2; // show grid lines
|
||
BiffWoHeaders = 4; // show sheet headers
|
||
BiffWoFrozen = 8; // panes are frozen
|
||
BiffWoZeros = $10; // show zeros; clear = show zeros as empty cells
|
||
BiffWoAutoGridColor = $20; // automatic grid line color; clear = manual
|
||
BiffWoColumnsRTL = $40; // columns from right to left; clear = left to right
|
||
BiffWoOutline = $80; // show outline symbols
|
||
BiffWoNoSplits = $100; // remove splits if pane freeze is removed
|
||
BiffWoSelected = $200; // sheet selected
|
||
BiffWoActive = $400; // sheet active
|
||
BiffWoPageBreak = $800; // show in page break preview; clear = normal view
|
||
|
||
{ List of named paper sizes. }
|
||
|
||
BiffPsUnknown = 0;
|
||
BiffPsA4 = 9;
|
||
BiffPsReservedMin = 118;
|
||
BiffPsReservedMax = 255;
|
||
BiffPsCustomMin = 256;
|
||
|
||
{ Flags for BOF record as specified
|
||
in [MS-XLS] section 2.4.21. }
|
||
|
||
BiffBoffWin = 1;
|
||
BiffBoffRisc = 2;
|
||
BiffBoffBeta = 4;
|
||
BiffBoffWinAny = 8;
|
||
BiffBoffMacAny = $10;
|
||
BiffBoffBetaAny = $20;
|
||
BiffBoffRiscAny = $100;
|
||
BiffBoffFontLim = $2000;
|
||
|
||
{ Flags for WSBOOL record.
|
||
See [MS-XLS] section 2.4.351 }
|
||
|
||
BiffWsbShowBreaks = $0001; // show page breaks that added automatically
|
||
BiffWsbDialog = $0010; // sheet is dialog
|
||
BiffWsbOutline = $0020;
|
||
BiffWsbRowSums = $0040;
|
||
BiffWsbColSums = $0080;
|
||
BiffWsbFitPage = $0100; // fit the sheet to a print page
|
||
BiffWsbHSync = $1000;
|
||
BiffWsbVSync = $2000;
|
||
BiffWsbAltExpr = $4000;
|
||
BiffWsbAltFormulas = $8000;
|
||
|
||
type
|
||
|
||
{ BIFF stream.
|
||
|
||
BIFF stream is a sequence of small
|
||
data blocks named BIFF records. Each record
|
||
has a header (2 byte Id and 2 byte Size field)
|
||
and an optional data block. Normally, a BIFF stream
|
||
starts with a BOF record and ends with a EOF record. }
|
||
|
||
TBiffStream = class;
|
||
|
||
TBiffRecord = class
|
||
private
|
||
|
||
FOwner: TBiffStream;
|
||
FOffset: Cardinal;
|
||
|
||
function GetRecId: TBiffRecId;
|
||
function GetSize: Cardinal;
|
||
procedure SetSize(n: Cardinal);
|
||
|
||
public
|
||
|
||
constructor Create(Owner: TBiffStream; Offset: Cardinal);
|
||
|
||
{ These methods append data to the record }
|
||
|
||
procedure Write(const Buffer; Count: Cardinal);
|
||
procedure WriteConst(Value, Size: Cardinal);
|
||
procedure WriteZeros(Size: Cardinal);
|
||
procedure WriteStream(Stream: TStream);
|
||
|
||
{ Allows to write data at arbitrary place inside the record }
|
||
|
||
procedure WriteBytes(Offset, Data, Count: Cardinal);
|
||
|
||
{ Saves and loads contents of the record }
|
||
|
||
procedure SaveToStream(Stream: TStream);
|
||
procedure LoadFromStream(Stream: TStream);
|
||
|
||
{ Each BIFF record has an Id value that
|
||
defines a type of the contents }
|
||
|
||
property Id: TBiffRecId read GetRecId;
|
||
|
||
{ Size of the record's contents. This size doesn't include
|
||
the 4-byte record header. }
|
||
|
||
property Size: LongWord read GetSize write SetSize;
|
||
|
||
{ Each BIFF record is stored within a BIFF stream.
|
||
This value contains an offset in bytes from the
|
||
beginning of the BIFF stream to this BIFF record. }
|
||
|
||
property Offset: LongWord read FOffset;
|
||
|
||
end;
|
||
|
||
TBiffStream = class
|
||
private
|
||
|
||
FStream: TStream;
|
||
FRecords: TListCache; // List of TBiffRecord
|
||
FLastRec: TBiffRecord; // Last added record
|
||
|
||
function ReadBytes(Offset, Count: Cardinal): Cardinal;
|
||
procedure WriteBytes(Offset, Data, Count: Cardinal);
|
||
|
||
procedure Append(Data: Cardinal; Count: Cardinal);
|
||
procedure AppendData(const Data; Count: Cardinal);
|
||
procedure AppendRecord(Rec: TBiffRecord; const Data; DataSize: Cardinal);
|
||
|
||
function GetRecord(Index: Integer): TBiffRecord;
|
||
function GetRecCount: Integer;
|
||
function GetSize: Cardinal;
|
||
|
||
public
|
||
|
||
constructor Create(Cached: Boolean = False);
|
||
destructor Destroy; override;
|
||
|
||
function Add(Id: TBiffRecId): TBiffRecord;
|
||
function AddBOF(k: TBiffStreamKind): TBiffRecord;
|
||
function AddEOF: TBiffRecord;
|
||
|
||
procedure SaveToStream(Stream: TStream);
|
||
|
||
property Records[Index: LongInt]: TBiffRecord read GetRecord; default;
|
||
property Count: Integer read GetRecCount;
|
||
property Size: Cardinal read GetSize;
|
||
|
||
end;
|
||
|
||
{ BIFF object.
|
||
|
||
BIFF object is anything that has
|
||
representation in a BIFF stream.
|
||
BIFF objects are: workbook, worksheet,
|
||
text cell, unicode string and so on. }
|
||
|
||
TBiffObject = class
|
||
|
||
{ Every BIFF object must be capable to
|
||
serialize itself in a BIFF stream. }
|
||
|
||
procedure Flush(Stream: TBiffStream); virtual; abstract;
|
||
|
||
function GetHashCode: LongInt; reintroduce; virtual;
|
||
function Equals(s: TBiffObject): Boolean; reintroduce; virtual;
|
||
|
||
{ This method calls Flush method for each BIFF object
|
||
in the list. }
|
||
|
||
class procedure FlushList(list: TObjList; Stream: TBiffStream);
|
||
|
||
end;
|
||
|
||
//
|
||
// BIFF8 unicode string
|
||
//
|
||
|
||
TBiffUCS = class(TBiffObject)
|
||
private
|
||
|
||
FData: WideString;
|
||
FRuns: TMemoryStream;
|
||
FHash: LongInt;
|
||
FCompress: Boolean;
|
||
|
||
procedure SetData(const Value: WideString);
|
||
|
||
{ UCS16 string is compressible if it contains only
|
||
symbols in range 0..255, i.e. the high byte of each symbol
|
||
is zero. }
|
||
|
||
function IsCompressible: Boolean;
|
||
|
||
procedure Init;
|
||
|
||
public
|
||
|
||
Len16: Boolean; // set, if the length of this string must occupy two bytes
|
||
Tag: LongInt; // not used by this class
|
||
SstIndex: Integer; // not used by this class
|
||
|
||
constructor Create; overload;
|
||
constructor Create(const S: WideString; UCS16: Boolean); overload;
|
||
destructor Destroy; override;
|
||
|
||
procedure AddFormat(Position, Font: LongInt);
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
{ Compares itself with a TBiffUCS using
|
||
a created hash. }
|
||
|
||
function Equals(s: TBiffObject): Boolean; override;
|
||
|
||
{ Returns a hash code for this string.
|
||
The created hash code is cached. }
|
||
|
||
function GetHashCode: LongInt; override;
|
||
|
||
property Data: WideString read FData write SetData;
|
||
property Compress: Boolean read FCompress write FCompress;
|
||
|
||
end;
|
||
|
||
//
|
||
// STYLE
|
||
//
|
||
|
||
TBiffBuiltinStyleId = (
|
||
bsiNormal,
|
||
bsiRowLevel,
|
||
bsiColLevel,
|
||
bsiCOmma,
|
||
bsiCurrency,
|
||
bsiPercent,
|
||
bsiComma0,
|
||
bsiCurrency0,
|
||
bsiHyperlink,
|
||
bsiFHyperlink);
|
||
|
||
TBiffStyle = class(TBiffObject)
|
||
public
|
||
|
||
XF: LongInt;
|
||
StyleId: LongInt;
|
||
Level: LongInt;
|
||
Name: WideString;
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
//
|
||
// BLANK
|
||
//
|
||
|
||
TBiffCell = class(TBiffObject)
|
||
public
|
||
|
||
Row: LongInt;
|
||
Col: LongInt;
|
||
XF: LongInt;
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
//
|
||
// Link Table (EXTRENALBOOK, EXTERNALSHEET, etc.)
|
||
//
|
||
|
||
TBiffLinkTable = class(TBiffObject)
|
||
private
|
||
|
||
{ i-th REF is associated with a sheet named FIntSheetNames[i],
|
||
which has index FIntSheetIndex[i] in the workbook }
|
||
|
||
FIntSheetNames: array of string;
|
||
FIntSheetIndex: array of Integer;
|
||
FSheetsCount: Integer;
|
||
|
||
function FindSheet(const Name: string): Integer;
|
||
|
||
function GetRefsCount: Integer;
|
||
procedure SetRefsCount(n: Integer);
|
||
public
|
||
|
||
{ The Link Table contains a mapping from internal sheet names to
|
||
indices to REF records. Formulas need this mapping: in expression
|
||
like SheetABC!G8 the sheet name SheetABC is stored indirectly,
|
||
via an associated with it an index to its REF record. }
|
||
|
||
function GetInternalSheetRef(const SheetName: string): Integer;
|
||
|
||
{ Links a sheet name with a corresponding sheet index. Sheet indices are known
|
||
by TBiffWorkbook, so this method is called by the workbook. }
|
||
|
||
procedure SetSheetIndex(const SheetName: string; Index: Integer);
|
||
|
||
{ Writes itself as a series of record. A link table is repersented with several
|
||
records, unlike the most of other objects, which are represented by one record. }
|
||
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
property RefsCount: Integer read GetRefsCount write SetRefsCount;
|
||
property SheetsCount: Integer read FSheetsCount write FSheetsCount;
|
||
end;
|
||
|
||
//
|
||
// FORMULA
|
||
//
|
||
|
||
TBiffFormulaCell = class(TBiffCell)
|
||
private
|
||
FInst: TStream;
|
||
public
|
||
constructor Create(Instructions: TStream);
|
||
destructor Destroy; override;
|
||
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
end;
|
||
|
||
{ Formulas lexer }
|
||
|
||
TBiffFormulaLexemKind =
|
||
(
|
||
flkVoid, // indicates that a lexem does not exist
|
||
flkSpace, // several characters that are considered to be whitespaces
|
||
flkName, // a sequence of letters and numbers: ABS, LOG, but not LOG10, A11
|
||
flkInt, // an unsigned integer
|
||
flkString, // a string
|
||
flkOp, // an operator, like < > <= >= <> & * + -
|
||
flkSymbol // some special symbol of unrecognized meaning
|
||
);
|
||
|
||
TBiffFormulaLexem = record
|
||
Kind: TBiffFormulaLexemKind;
|
||
Text: string;
|
||
end;
|
||
|
||
TBiffFormulaLexer = class
|
||
private
|
||
FText: string;
|
||
FPos: Integer;
|
||
FLexems: array of TBiffFormulaLexem;
|
||
|
||
function IsAlpha(c: Char): Boolean;
|
||
function IsDigit(c: Char): Boolean;
|
||
|
||
function Read(Len: Integer): string;
|
||
function GetChar: Char;
|
||
function NextChar: Char;
|
||
procedure SkipChar;
|
||
function SubStr(Pos, Len: Integer): string;
|
||
|
||
procedure Add(const Lex: TBiffFormulaLexem); overload;
|
||
procedure Add(LexKind: TBiffFormulaLexemKind; const LexText: string); overload;
|
||
|
||
function AddSpace: Boolean;
|
||
function AddNumber: Boolean;
|
||
function AddSymbol: Boolean;
|
||
function AddName: Boolean;
|
||
function AddString(Quote: Char): Boolean;
|
||
function AddOp: Boolean;
|
||
|
||
function GetLexemsCount: Integer;
|
||
function GetLexem(i: Integer): TBiffFormulaLexem;
|
||
|
||
procedure Analyse(const Formula: string);
|
||
public
|
||
property Formula: string read FText write Analyse;
|
||
property Count: Integer read GetLexemsCount;
|
||
property Lexems[i: Integer]: TBiffFormulaLexem read GetLexem; default;
|
||
end;
|
||
|
||
{ Formulas RPN stack }
|
||
|
||
TBiffFormulaTokenKind =
|
||
(
|
||
ftkVoid,
|
||
ftkArg,
|
||
ftkOp // pops a number of args and pushes one result back; Flags = the number of args
|
||
);
|
||
|
||
TBiffFormulaOperatorKind =
|
||
(
|
||
fokVoid,
|
||
fokPush, // pushes to stack one argument
|
||
|
||
fokDiv100, // %
|
||
fokNeg, // -
|
||
|
||
fokAdd, // +
|
||
fokSub, // -
|
||
fokDiv, // /
|
||
fokMul, // *
|
||
fokPow, // ^
|
||
|
||
fokArea, // : creates a cell area (A2:G6)
|
||
fokColon, // : creates a cell area like fokArea, but more general (A2:INDIRECT("G6"))
|
||
fokIsect, // intersects two ranges, e.g. A1:G5 A2:H7; denoted by one space character
|
||
fokExt, // ! is used to refer to an external cell; e.g. "Sheet 10"!G6
|
||
fokJoin, // & joins two strings; e.g. "123" & "abc"
|
||
|
||
fokL, // <
|
||
fokG, // >
|
||
fokE, // =
|
||
fokNE, // <>
|
||
fokLE, // <=
|
||
fokGE, // >=
|
||
|
||
fokNull, // null value; it's used for representing a missing argument: SUM(A12,,7)
|
||
fokNumber, // a floating point number
|
||
fokBool, // a boolean value; Flags = 1 means "true", Flags = 0 means "false"
|
||
fokString, // a string
|
||
fokCell, // a cell reference; Flags: bit 0 = row is relative; bit 1 = column is relative
|
||
fokFunc, // a function call
|
||
fokId // the identity operator; pops one arg and pushes it back unmodified
|
||
);
|
||
|
||
TBiffFormulaToken = record
|
||
Kind: TBiffFormulaTokenKind;
|
||
Op: TBiffFormulaOperatorKind;
|
||
Text: string;
|
||
Flags: Integer;
|
||
end;
|
||
|
||
TBiffFormulaTokenArray = array of TBiffFormulaToken;
|
||
|
||
TBiffFormulaRPNStack = class
|
||
private
|
||
FNumArgs: Integer; // number of arguments in FCode
|
||
FCode: TBiffFormulaTokenArray; // resulting program
|
||
FStack: TBiffFormulaTokenArray; // stack of operators awaiting to being unrolled
|
||
FFrame: TBiffFormulaTokenArray; // stack of function calls
|
||
|
||
procedure Error(const Msg: string);
|
||
procedure Ensure(b: Boolean; const Msg: string = 'RPN stack failed');
|
||
|
||
procedure Push(var Res: TBiffFormulaTokenArray; const t: TBiffFormulaToken);
|
||
function Pop(var a: TBiffFormulaTokenArray): TBiffFormulaToken;
|
||
function Top(const a: TBiffFormulaTokenArray): TBiffFormulaToken;
|
||
|
||
procedure PushOp(Op: TBiffFormulaToken); overload; // pushes an arith op recognizing the precedence order
|
||
procedure PopOp; // moves one operator from FStack to FCode
|
||
|
||
procedure Unroll; // unrolls one frame
|
||
function Joinable(Op: TBiffFormulaOperatorKind): Boolean; // whether Op can be added on top of FStack
|
||
|
||
function OpPriority(Kind: TBiffFormulaOperatorKind): Integer;
|
||
|
||
function GetCount: Integer;
|
||
function GetInstruction(i: Integer): TBiffFormulaToken;
|
||
function GetFrameArgs: Integer; // number of available arguments in the current frame
|
||
function GetFrameOps: Integer; // number of operators in the current frame
|
||
public
|
||
procedure PushArg(Op: TBiffFormulaOperatorKind; const Text: string; Flags: Integer = 0);
|
||
procedure PushOp(Op: TBiffFormulaOperatorKind; const Text: string; NumArgs: Integer = 0); overload;
|
||
|
||
procedure PushFrame(const Func: string = ''); // pushes a function call
|
||
procedure PopFrame; // it's called whenever the closing parenthesis occurs
|
||
|
||
property Count: Integer read GetCount;
|
||
property Instructions[i: Integer]: TBiffFormulaToken read GetInstruction; default;
|
||
end;
|
||
|
||
EBiffFormulaRPNStackError = class(Exception);
|
||
|
||
{ Formulas parser
|
||
|
||
BNF of accepted formulas:
|
||
|
||
formula ::= ppterm (binop ppterm)*
|
||
ppterm := [prefop] term [postop]
|
||
term ::= cell | area | string | number | func | name | extcell | extarea
|
||
func ::= [name [int]] "(" [formula] ("," formula)* ")"
|
||
number ::= int [ "." int ]
|
||
cell ::= ["$"] name ["$"] int
|
||
extcell ::= sheet "!" cell
|
||
extarea ::= sheet "!" area
|
||
area ::= cell ":" cell
|
||
sheet ::= string | name
|
||
binop ::= "+" | "-" | "*" | "/" | "^" | etc.
|
||
prefop ::= "-" | "+"
|
||
postop ::= "%"
|
||
|
||
(string, int, name - indivisible lexems; they are emitted by the lexer)
|
||
|
||
After a formula analysed, the parser builds a sequence of tokens (instructions)
|
||
available through its Tokens property. Each token represents an instruction or an argument
|
||
for an instruction. This a token can have one of two kinds:
|
||
|
||
ftkOp A token of this kind represents an instruction that must be executed
|
||
by a virtual processor. The Flags field defines the number of arguments
|
||
taken.
|
||
|
||
ftkArg A token of this kind represents an argument, which can be a number, a string,
|
||
a cell, the null arguments and so on. This token is not an instruction and
|
||
its only purpose is to be an argument for a token of kind ftkOp.
|
||
|
||
Here is an example of tokens produced from the formula "SUM(A3:B4 G5) + SheetABC!$G$8^2":
|
||
|
||
cell(A3) This is an argument token. It represents a cell.
|
||
cell(B4)
|
||
area:2 This is an operator token. It takes two previous tokens, makes an area (A3:B4) and
|
||
pushes the area to the stack.
|
||
cell(G5)
|
||
push:1 This is an operator token. It takes on previous token (G5) and pushes it to the stack.
|
||
isect:2 This operator pops two values from the stack, intersects them and pushes the result back.
|
||
call(SUM):1 This operator pops one value from the stack, calls SUM and pushes the result to the stack.
|
||
str(SheetABC) This is an argument token. It represents a string.
|
||
cell(G8):3 Here "3" is the Flags field. It has bits 0 and 1 set. This means that
|
||
the row and the column are absolute, not relative.
|
||
extcell:2 This operator takes 2 previous tokens ("SheetABC", "$G$8"), makes an external cell
|
||
reference from them (SheetABC!$G$8) and pushes it onto the stack.
|
||
num(2) This is an argument.
|
||
pow:2 This operator takes two values from the stack (SheetABC!$G$8 and 2), does exponentiation
|
||
and pushes the result (SheetABC!$G$8^2) onto the stack.
|
||
add:2 Like as pow:2, but does addition. }
|
||
|
||
TBiffFormulaParser = class
|
||
private
|
||
FLexems: array of TBiffFormulaLexem;
|
||
FPos: Integer; // current lexem
|
||
FSavedPos: array of Integer;
|
||
FRPN: TBiffFormulaRPNStack;
|
||
FCode: TBiffFormulaTokenArray;
|
||
|
||
function CreateArgToken(Kind: TBiffFormulaOperatorKind;
|
||
const Text: string = ''; Flags: Integer = 0): TBiffFormulaToken;
|
||
|
||
{ emits two tokens: arg and push }
|
||
|
||
procedure Push(Arg: TBiffFormulaOperatorKind; const Text: string = ''; Flags: Integer = 0);
|
||
|
||
{ errors reporing }
|
||
|
||
procedure Error(const ErrorMsg: string);
|
||
procedure Ensure(b: Boolean; const ErrorMsg: string = 'Invalid formula');
|
||
|
||
{ lexems traversing }
|
||
|
||
function Lexem(i: Integer = 0): TBiffFormulaLexem; // returns (FPos + i) lexem or flkVoid
|
||
procedure SkipLexem;
|
||
function SkipLexemIf(const Text: string): Boolean; overload;
|
||
function SkipLexemIf(Kind: TBiffFormulaLexemKind; out Text: string): Boolean; overload;
|
||
function IsOp(const Lex: TBiffFormulaLexem; const Text: string): Boolean;
|
||
function IsArgSep(const Lex: TBiffFormulaLexem): Boolean;
|
||
|
||
{ parser's state saving/restoring }
|
||
|
||
procedure Save; // saves the parser's state
|
||
procedure Load; // loads the parser's state
|
||
procedure Discard; // discards the last saved state
|
||
|
||
{ operators propeties }
|
||
|
||
function OpKind(const s: string): TBiffFormulaOperatorKind;
|
||
|
||
{ parsing methods }
|
||
|
||
procedure Parse(const s: string);
|
||
procedure BuildLexems(const s: string);
|
||
procedure CleanLexems;
|
||
procedure CopyCodeFromRPNStack;
|
||
|
||
function ReadSym(const s: string): Boolean;
|
||
function ReadString(out s: string): Boolean;
|
||
function ReadNumber(out s: string): Boolean;
|
||
function ReadName(out s: string): Boolean;
|
||
function ReadOp(out s: string): Boolean;
|
||
function ReadSheet(out s: string): Boolean;
|
||
function ReadCell(out t: TBiffFormulaToken): Boolean;
|
||
|
||
function ParseFormula: Boolean;
|
||
function ParsePPTerm: Boolean;
|
||
function ParsePrefOp: Boolean;
|
||
function ParsePostOp: Boolean;
|
||
function ParseTerm: Boolean;
|
||
function ParseString: Boolean;
|
||
function ParseNumber: Boolean;
|
||
function ParseCell: Boolean;
|
||
function ParseArea: Boolean;
|
||
function ParseBinOp: Boolean;
|
||
function ParseFuncCall: Boolean;
|
||
function ParseNameConst: Boolean;
|
||
function ParseExtCell: Boolean;
|
||
function ParseExtArea: Boolean;
|
||
|
||
{ property getters/setters }
|
||
|
||
function GetToken(i: Integer): TBiffFormulaToken;
|
||
function GetTokensCount: Integer;
|
||
public
|
||
property Formula: string write Parse;
|
||
property Tokens[i: Integer]: TBiffFormulaToken read GetToken; default;
|
||
property Count: Integer read GetTokensCount;
|
||
end;
|
||
|
||
EBiffFormulaParserError = class(Exception);
|
||
|
||
{ Formulas code emitter }
|
||
|
||
TBiffFormulaCellRef = record
|
||
Row: Integer; // zero based row index
|
||
Col: Integer; // zero based column index
|
||
AbsRow: Boolean; // row index is absolute; in $G7 the index is absolute; in G7 it's relative
|
||
AbsCol: Boolean; // column index is absolute; in G$7 the index is absolute; in G7 it's relative
|
||
end;
|
||
|
||
TBiffFormulaRetType = (frtVoid, frtRef, frtVal, frtArray);
|
||
|
||
TBiffFormulaCodeEmitter = class
|
||
private
|
||
FInst: TStream;
|
||
FRetTypeMode: TBiffFormulaRetType;
|
||
|
||
procedure Error(const ErrorMsg: string);
|
||
procedure Ensure(b: Boolean; const ErrorMsg: string = 'Cannot emit opcode');
|
||
procedure EnsureCellRange(const Cell: TBiffFormulaCellRef);
|
||
|
||
function RelFlags(RelRow, RelCol: Boolean): Byte;
|
||
|
||
procedure WriteOpCode(Op: Byte);
|
||
procedure Write(Inst: Cardinal; Len: Cardinal = 1);
|
||
procedure WriteCellRef(const Cell: TBiffFormulaCellRef);
|
||
procedure WriteAreaRef(const Cell1, Cell2: TBiffFormulaCellRef);
|
||
public
|
||
|
||
{ commands that push a value on the stack }
|
||
|
||
procedure Push(Value: Integer); overload;
|
||
procedure Push(Value: Double); overload;
|
||
procedure Push(b: Boolean); overload;
|
||
procedure Push(const s: string); overload;
|
||
procedure PushNull;
|
||
procedure PushCell(const Cell: TBiffFormulaCellRef);
|
||
procedure PushArea(const Cell1, Cell2: TBiffFormulaCellRef);
|
||
procedure PushExtCell(SheetRefId: Integer; const Cell: TBiffFormulaCellRef);
|
||
procedure PushExtArea(SheetRefId: Integer; const Cell1, Cell2: TBiffFormulaCellRef);
|
||
|
||
{ function calls }
|
||
|
||
procedure Call(Func: Cardinal); overload;
|
||
procedure Call(Func, NumArgs: Cardinal); overload;
|
||
procedure CallId; // identity function; emits parethesis for display purposes
|
||
|
||
{ unary operators }
|
||
|
||
procedure Neg; // unary -
|
||
procedure Div100; // %
|
||
|
||
{ binary arithmetic operators }
|
||
|
||
procedure Add; // +
|
||
procedure Sub; // -
|
||
procedure Mul; // *
|
||
procedure Divide; // /
|
||
procedure Pow; // ^
|
||
|
||
{ binary comparsion operators }
|
||
|
||
procedure CmpL; // <
|
||
procedure CmpG; // >
|
||
procedure CmpLE; // <=
|
||
procedure CmpGE; // >=
|
||
procedure CmpE; // =
|
||
procedure CmpNE; // <>
|
||
|
||
{ cell operators }
|
||
|
||
procedure Intersect; // intersects two areas
|
||
procedure Range; // :
|
||
|
||
{ string operators }
|
||
|
||
procedure Join; // &
|
||
|
||
property Output: TStream read FInst write FInst;
|
||
property RetMode: TBiffFormulaRetType read FRetTypeMode write FRetTypeMode;
|
||
end;
|
||
|
||
EBiffFormulaCodeEmitterError = class(Exception);
|
||
|
||
{ Functions list.
|
||
|
||
todo -cOptimisation: This clumsy class represents a map which stores items
|
||
sorted by key. It can be represented by AVL, red-black or b-tree,
|
||
but because of lack of generics in old Delphi versions,
|
||
there's no easy way adapt existing classes in frxStorage for
|
||
string keys. In far future this class should be replaced with something like
|
||
TAVLTree<string, TBiffFormulaFunc>. }
|
||
|
||
TBiffFormulaFunc = record
|
||
Name: string;
|
||
Id: Integer;
|
||
MinArgs: Integer;
|
||
MaxArgs: Integer;
|
||
Volatile: Boolean;
|
||
RetType: Char;
|
||
ArgTypes: string;
|
||
end;
|
||
|
||
TBiffFormulaFuncArray = array of TBiffFormulaFunc;
|
||
|
||
TBiffFormulaFuncList = class
|
||
private
|
||
class procedure Init;
|
||
class procedure Add(const f: TBiffFormulaFunc); overload;
|
||
class function Find(Name: string): Integer;
|
||
class function GetCount: Integer;
|
||
class function GetFunc(i: Integer): TBiffFormulaFunc;
|
||
class procedure SetFunc(i: Integer; const f: TBiffFormulaFunc);
|
||
class procedure SetCount(n: Integer);
|
||
public
|
||
|
||
{ [MS-XLS] Section 2.5.198.17
|
||
|
||
Name The function name. Letters case doesn't matter - this method upcases all letters.
|
||
Id The function id. It can be found in the documentation.
|
||
MinArgs The minimum number of arguments the function takes.
|
||
MaxArgs The maximum number of arguments the function takes.
|
||
RetType The result type. See note below.
|
||
ArgTypes Arguments types. The actual length of this array can be less than MaxArgs. In this
|
||
case all missing entries are assumed to be equal to the last entry; e.g.
|
||
SUM takes up to 30 args and all of them are references, so ArgTypes can be set to
|
||
"r" or "rr" or "rrr" - all these strings are equally assumed to be equal to the string
|
||
with 30 r's - "rrr....rrr".
|
||
|
||
Result type of arguments types take one of three values: 'R' (reference), 'V' (value) and 'A' (array).
|
||
See docs for meaning of these types. }
|
||
|
||
class procedure Add(Id: Integer; Name: string; MinArgs, MaxArgs: Integer;
|
||
RetType: Char; ArgTypes: string; Volatile: Boolean = False); overload;
|
||
|
||
class function Exists(const Name: string): Boolean;
|
||
class function Get(const Name: string): TBiffFormulaFunc;
|
||
class function GetArgType(const Name: string; i: Integer): Char;
|
||
end;
|
||
|
||
{ Formulas compiler }
|
||
|
||
TBiffFormulaCompiler = class
|
||
private
|
||
FParser: TBiffFormulaParser;
|
||
FPos: Integer; // current token
|
||
FEmitter: TBiffFormulaCodeEmitter;
|
||
FCode: TStream;
|
||
FLinkTable: TBiffLinkTable;
|
||
FRetTypes: array of TBiffFormulaRetType;
|
||
|
||
function GetLinkTable: TBiffLinkTable;
|
||
|
||
function Token(i: Integer = 0): TBiffFormulaToken;
|
||
procedure SkipToken;
|
||
procedure SelectToken(i: Integer);
|
||
|
||
procedure Error(const Fmt: string; const Args: array of const);
|
||
procedure Ensure(b: Boolean; const ErrorMsg: string = 'Cannot compile formula'); overload;
|
||
procedure Ensure(b: Boolean; const Fmt: string; const Args: array of const); overload;
|
||
|
||
function IsCell(const t: TBiffFormulaToken): Boolean;
|
||
function IsStr(const t: TBiffFormulaToken): Boolean;
|
||
|
||
function GetCellPos(const t: TBiffFormulaToken): TBiffFormulaCellRef;
|
||
|
||
{ Excel doesn't perform types coercion. This method finds for each token
|
||
what type it should return. }
|
||
|
||
procedure CalcRetTypes;
|
||
|
||
procedure Compile(const s: string);
|
||
procedure CompileToken;
|
||
|
||
procedure EmitNum(Num: Double);
|
||
procedure EmitOp(Kind: TBiffFormulaOperatorKind; NumArgs: Integer);
|
||
procedure EmitFunc(Name: string; NumArgs: Integer);
|
||
procedure EmitIdFunc(NumArgs: Integer);
|
||
procedure EmitArea(const Cell1, Cell2: TBiffFormulaToken);
|
||
procedure EmitExtCell(const Sheet, Cell: TBiffFormulaToken);
|
||
procedure EmitExtArea(const Sheet, Cell1, Cell2: TBiffFormulaToken);
|
||
procedure EmitPush(const t: TBiffFormulaToken);
|
||
public
|
||
constructor Create;
|
||
destructor Destroy; override;
|
||
|
||
procedure SaveToStream(Stream: TStream);
|
||
|
||
property Formula: string write Compile;
|
||
|
||
{ Link table is needed to compile external cell references: SheetABC!G8.
|
||
If the formula doesn't contain such expressions, then LinkTable can be left nil. }
|
||
|
||
property LinkTable: TBiffLinkTable read GetLinkTable write FLinkTable;
|
||
end;
|
||
|
||
EBiffFormulaCompilerError = class(Exception);
|
||
|
||
//
|
||
// LABELSST
|
||
//
|
||
|
||
TBiffTextCell = class(TBiffCell)
|
||
public
|
||
|
||
SST: LongInt;
|
||
|
||
constructor Create(SST: LongInt);
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
//
|
||
// NUMBER
|
||
//
|
||
|
||
TBiffNumberCell = class(TBiffCell)
|
||
public
|
||
|
||
Value: Double; // IEEE 754 floating-point value (64-bit double precision)
|
||
|
||
constructor Create(Value: Double);
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
//
|
||
// Palette.
|
||
//
|
||
// BIFF document can contain a PALETTE record
|
||
// which specifies an array of used colors.
|
||
// To refer to a color in this array, a color index
|
||
// is used. There're several special built-in
|
||
// colors. Their indexes are defined below.
|
||
//
|
||
|
||
TBiffColorIndex = (
|
||
ciBlack,
|
||
ciWhite,
|
||
ciRed,
|
||
ciGreen,
|
||
ciBlue,
|
||
ciYellow,
|
||
ciMagenta,
|
||
ciCyan
|
||
);
|
||
|
||
//
|
||
// Font.
|
||
//
|
||
|
||
TBiffFontOptions = LongInt; // See fo*** values
|
||
|
||
TBiffFontFamily = (
|
||
ffNone,
|
||
ffRoman,
|
||
ffSwiss,
|
||
ffModern,
|
||
ffScript,
|
||
ffDecorative);
|
||
|
||
TBiffFontEscapement = (
|
||
feNone,
|
||
feSuperScript,
|
||
feSubScript);
|
||
|
||
TBiffFontUnderline = LongInt; // See fu*** values
|
||
TBiffFontWeight = LongInt; // See fw*** values
|
||
|
||
TBiffFontData = record
|
||
|
||
Height: LongInt; // Font height in twips = 1/20 of a point
|
||
Options: Word; // See TBiffFontOptions
|
||
Color: Word; // Index to a color
|
||
Weight: Word;
|
||
Esc: TBiffFontEscapement;
|
||
Underline: TBiffFontUnderline;
|
||
Family: TBiffFontFamily;
|
||
Charset: Byte; // For byte strings
|
||
|
||
end;
|
||
|
||
TBiffFont = class(TBiffObject)
|
||
public
|
||
|
||
Data: TBiffFontData;
|
||
Name: WideString;
|
||
Hash: Integer;
|
||
FontIndex: Integer; // not used by this class
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
function Equals(Font: TBiffObject): Boolean; override;
|
||
function GetHashCode: Integer; override;
|
||
|
||
//
|
||
// Returns width in points of a specified string as though
|
||
// it's drawed with this font. On failure, returns 0.
|
||
//
|
||
// This function is complicated and its results
|
||
// should be cached to increase performance.
|
||
//
|
||
|
||
function StrWidth(const Str: WideString): LongInt;
|
||
|
||
end;
|
||
|
||
//
|
||
// XF.
|
||
//
|
||
// Extended cell formatting.
|
||
//
|
||
|
||
TBiffXFTypeProt = LongInt; // See xftp** values
|
||
TBiffXFUsedAttrib = LongInt;// See BiffXfua*** values
|
||
TBiffPatternStyle = LongInt;// See ps*** values
|
||
|
||
TBiffXFHAlign = (
|
||
xfhaGeneral,
|
||
xfhaLeft,
|
||
xfhaCentered,
|
||
xfhaRight,
|
||
xfhaFilled,
|
||
xfhaJustified,
|
||
xfhaCAS, // Centred across selection
|
||
xfhaDistributed);
|
||
|
||
TBiffXFVAlign = (
|
||
xfvaTop,
|
||
xfvaCentered,
|
||
xfvaBottom,
|
||
xfvaJustified,
|
||
xfvaDistributed);
|
||
|
||
TBiffXFTextDir = (
|
||
xftdAuto,
|
||
xftdLTR,
|
||
xftdRTL);
|
||
|
||
TBiffXFOrientation = (
|
||
xfoNone,
|
||
xfoTop, // Letters are stacked top-to-bottom, but not rotated
|
||
xfo90CCW, // 90 degrees counterclockwise
|
||
xfo90CW); // 90 degrees clockwise
|
||
|
||
TBiffLineStyle = (
|
||
lsNone,
|
||
lsThin,
|
||
lsMedium,
|
||
lsDashed,
|
||
lsDotted,
|
||
lsThick,
|
||
lsDouble,
|
||
lsHair,
|
||
lsMediumDashed,
|
||
lsThinDashDotted,
|
||
lsMediumDashDotted,
|
||
lsThinDashDotDotted,
|
||
lsMediumDashDotDotted,
|
||
lsSlantedMediumDashDotted
|
||
);
|
||
|
||
TBiffLine = record
|
||
|
||
Style: TBiffLineStyle;
|
||
Color: Byte; // Index to a color
|
||
|
||
end;
|
||
|
||
TBiffXfData = record
|
||
|
||
Font: LongInt; // Index to FONT record
|
||
Format: LongInt; // Index to FORMAT record
|
||
Prot: Byte; // See TBiffXFTypeProt
|
||
Parent: LongInt; // Index to parent XF. Always -1 in style XFs.
|
||
HAlign: TBiffXFHAlign;
|
||
WordWrap: Boolean;
|
||
VAlign: TBiffXFVAlign;
|
||
Justify: Boolean; // Justify last line in justified or distibuted text
|
||
Rotation: Byte;
|
||
|
||
//
|
||
// Indent level is measured in units,
|
||
// each of them equals to length of three
|
||
// blank characters.
|
||
//
|
||
|
||
Indent: Byte;
|
||
|
||
Shrink: Boolean; // Shrink content to fit into cell
|
||
Direction: TBiffXFTextDir;
|
||
UsedAttrs: Byte; // See TBiffXFUsedAttrib
|
||
|
||
L, T, R, B: TBiffLine; // Left, top, right and bottom lines
|
||
D: TBiffLine; // Diagonal line
|
||
LTRB: Boolean; // Diagonal line from left-top to right-bottom
|
||
LBRT: Boolean; // Diagonal line from left-bottom to right-top
|
||
|
||
Patt: Byte; // See TBiffPatternStyle and docs
|
||
PattColor: Word; // Index to a color
|
||
PattBgColor:Word; // Index to a color
|
||
|
||
end;
|
||
|
||
TBiffXF = class(TBiffObject)
|
||
public
|
||
|
||
XfIndex: Integer; // Index to XF table. Not used by this class.
|
||
Data: TBiffXfData;
|
||
Hash: Integer;
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
function Equals(XF: TBiffObject): Boolean; override;
|
||
function GetHashCode: Integer; override;
|
||
|
||
end;
|
||
|
||
//
|
||
// COLINFO
|
||
// Defines formatting for several consequent columns.
|
||
//
|
||
|
||
TBiffColInfo = class(TBiffObject)
|
||
public
|
||
|
||
First: LongInt; // Index to the first column
|
||
Last: LongInt; // Index to the last column
|
||
XF: LongInt; // Index to an XF record
|
||
Hidden: Boolean;
|
||
Collapsed: Boolean;
|
||
Outline: Byte; // Must be in 0..7 range
|
||
Width: LongInt; // In 1/256 of the zero character of the 0-th font
|
||
|
||
constructor Create(Column, XF, Width: LongInt);
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
//
|
||
// WINDOW1
|
||
//
|
||
|
||
TBiffWindowOptions = LongInt; // See wo*** values
|
||
|
||
TBiffWindow = class
|
||
public
|
||
|
||
HPos, VPos: LongInt; // In twips = 1/20 of a point
|
||
Width, Height: LongInt; // In twips = 1/20 of a point
|
||
ActiveSheet: LongInt;
|
||
FirstTab: LongInt;
|
||
SelSheet: LongInt;
|
||
TabWidth: LongInt; // Worksheet tab bar. 1/1000 of window width
|
||
|
||
Visible: Boolean; // Window
|
||
Open: Boolean; // Open/minimized
|
||
HSBVisible: Boolean; // Hor. scroll bar
|
||
VSBVisible: Boolean; // Vert. scroll bar
|
||
TabVisible: Boolean; // Worksheet tab
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream);
|
||
|
||
end;
|
||
|
||
//
|
||
// ROW
|
||
//
|
||
|
||
TBiffRow = class(TBiffObject)
|
||
public
|
||
|
||
Row: LongInt; // Index to this row
|
||
Cells: TObjList; // List of TBiffCell
|
||
FirstCol: LongInt; // Index to column of the first cell
|
||
LastCol: LongInt; // Index to column of the last cell
|
||
Height: LongInt; // Height in twips
|
||
Outline: Byte; // Valid outline levels are 0..7
|
||
XF: LongInt; // Index to an XF record
|
||
Hidden: Boolean;
|
||
|
||
{ These two fields are used by TBiffSheet, not
|
||
by this class.
|
||
|
||
- FirstCell - stream position of the first cell of this row
|
||
- Offset - stream position of this row }
|
||
|
||
FirstCell: LongWord;
|
||
Offset: LongWord;
|
||
|
||
constructor Create;
|
||
destructor Destroy; override;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
//
|
||
// PAGESETUP
|
||
//
|
||
|
||
TBiffPageOrientation = (
|
||
bpoLandscape,
|
||
bpoPortrait
|
||
);
|
||
|
||
TBiffPageSetup = class(TBiffObject)
|
||
public
|
||
|
||
Size: TBiffPaperSize;
|
||
Orient: TBiffPageOrientation;
|
||
Copies: LongInt;
|
||
Colored: Boolean; // Print in color or black and white
|
||
Xdpi: Word;
|
||
Ydpi: Word;
|
||
PrintInRows:Boolean;
|
||
Draft: Boolean; // Draft print quality
|
||
CellNotes: Boolean; // Print cell notes
|
||
SheetNotes: Boolean; // Print notes at the end of the sheet
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
{ FILEPASS
|
||
|
||
TBiffRC4 allows to encrypt excel workbook data using the RC4 cipher.
|
||
This class is serialized into the FILEPASS record. }
|
||
|
||
TBiffRC4 = class(TBiffObject)
|
||
private
|
||
|
||
{ Specific data to be written to the output
|
||
FILEPASS record }
|
||
|
||
FSalt: array[1..16] of Byte; // Random data
|
||
FVerifier: array[1..16] of Byte; // Encrypted verifier (that is random data)
|
||
FHash: array[1..16] of Byte; // Encrypted MD5 of the verifier
|
||
|
||
{ Partial hash required for creating
|
||
the encryption key. }
|
||
|
||
FTruncHash: array[1..5] of Byte;
|
||
|
||
{ RC4 cipher }
|
||
|
||
FCipher: TCryptoRC4;
|
||
|
||
{ Positioon of the currently encrypted byte }
|
||
|
||
FTail: LongInt;
|
||
FBlockId: LongInt;
|
||
|
||
procedure EncryptEx(Data: Pointer; Size: LongInt);
|
||
procedure MD5(out Hash; const Data; Size: Integer);
|
||
|
||
public
|
||
|
||
{ RC4 cipher performs a self test. If the test has failed,
|
||
an exception is raised. }
|
||
|
||
constructor Create;
|
||
destructor Destroy; override;
|
||
|
||
{ Creates a partial hash as specified in [MS-OFFCRYPTO] section 2.3.6.2. }
|
||
|
||
procedure Prepare(const Password; PassLen: LongInt);
|
||
|
||
{ Creates the FILEPASS record in a BIFF stream.
|
||
This routine must be called after the Prepare routine. }
|
||
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
{ Initializes the RC4 cipher with a specified key }
|
||
|
||
procedure Init(Key: Pointer; Len: LongInt);
|
||
|
||
{ Initializes the RC4 cipher as specified in [MS-OFFCRYPTO] section 2.3.6.2.
|
||
This routine must be called after the Prepare routine, because
|
||
Initialize uses the partial hash that's generated by Prepare }
|
||
|
||
procedure Initialize(BlockId: LongWord);
|
||
|
||
{ Encrypts a data block "in place".
|
||
The RC4 cipher generates a crypto stream (based on the password),
|
||
that is combined with the original data with XOR operation.
|
||
If Data is nil, the crypto stream is generated but is written
|
||
nowhere. }
|
||
|
||
procedure Encrypt(Data: Pointer; Size: LongInt); cdecl;
|
||
|
||
{ This routine encrypts a BIFF stream as specified in
|
||
[MS-XLS] section 2.2.10. }
|
||
|
||
procedure EncryptStream(Stream: TBiffStream);
|
||
end;
|
||
|
||
TBiffBounds = record
|
||
|
||
FR: LongInt; // First row
|
||
LR: LongInt; // Last row
|
||
FC: LongInt; // First column
|
||
LC: LongInt; // Last column
|
||
|
||
end;
|
||
|
||
//
|
||
// WINDOW2
|
||
//
|
||
|
||
TBiffWindow2 = class(TBiffObject)
|
||
public
|
||
|
||
Options: Word; // See BiffWo*** values
|
||
FirstRow: Word; // First visible row
|
||
FirstCol: Word; // First visible column
|
||
GridCol: Word; // Grid line color
|
||
MFPBP: Word; // Cached magnification factor in page break preview
|
||
CMFNV: Word; // Cached magnification factor in normal view
|
||
|
||
constructor Create;
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
end;
|
||
|
||
{ BIFF sheet.
|
||
|
||
Any XLS BIFF document consists of a few sheets.
|
||
A sheet is represented by class TBiffSheet.
|
||
An instance of this class can be accessed by a single
|
||
thread at a time. }
|
||
|
||
TBiffSheetKind = LongInt; // See sk*** values
|
||
|
||
TBiffSheetVisibility = (
|
||
svVisible,
|
||
svHidden,
|
||
svVeryHidden); // Such a sheet can only be shown/hidden by VB macro
|
||
|
||
TBiffMargin = record
|
||
|
||
Left: Double; // Inches
|
||
Top: Double;
|
||
Right: Double;
|
||
Bottom: Double;
|
||
|
||
end;
|
||
|
||
TRectangle = class
|
||
private
|
||
FRect: TRect;
|
||
function GetBottom: Integer;
|
||
function GetBottomRight: TPoint;
|
||
function GetLeft: Integer;
|
||
function GetRight: Integer;
|
||
function GetTop: Integer;
|
||
function GetTopLeft: TPoint;
|
||
procedure SetBottom(const Value: Integer);
|
||
procedure SetBottomRight(const Value: TPoint);
|
||
procedure SetLeft(const Value: Integer);
|
||
procedure SetRight(const Value: Integer);
|
||
procedure SetTop(const Value: Integer);
|
||
procedure SetTopLeft(const Value: TPoint);
|
||
public
|
||
property Bottom: Integer read GetBottom write SetBottom;
|
||
property BottomRight: TPoint read GetBottomRight write SetBottomRight;
|
||
property Left: Integer read GetLeft write SetLeft;
|
||
property Right: Integer read GetRight write SetRight;
|
||
property Top: Integer read GetTop write SetTop;
|
||
property TopLeft: TPoint read GetTopLeft write SetTopLeft;
|
||
end;
|
||
|
||
TBiffWorkbook = class;
|
||
|
||
TBiffSheet = class(TBiffObject)
|
||
private
|
||
|
||
FRows: TObjList; // List of TBiffRow. Sorted by the row index.
|
||
FCols: TObjList; // List of TBiffColInfo
|
||
FMrgCells: TObjectList; // rectangles of merged cells
|
||
FDGroup: TEscherGroup; // Drawing group. This class doesn't delete DGroup.
|
||
FOwner: TBiffWorkbook;
|
||
FKind: TBiffSheetKind;
|
||
FVis: TBiffSheetVisibility;
|
||
FPB: TList; // List of LongInt (indexes to row where a page break occurs)
|
||
FStrCount: LongInt; // number of text cells
|
||
|
||
FLastReadRow: Integer;
|
||
|
||
procedure SetColWidth(i: LongInt; w: LongInt);
|
||
procedure SetRowHeight(i: LongInt; h: LongInt);
|
||
function GetColWidth(i: LongInt): LongInt;
|
||
function GetRowHeight(i: LongInt): LongInt;
|
||
function GetRow(Index: LongInt): TBiffRow; // optimised for sequential access
|
||
|
||
public
|
||
|
||
Name: WideString;
|
||
Margin: TBiffMargin;
|
||
PageSetup: TBiffPageSetup;
|
||
View: TBiffWindow2;
|
||
Bounds: TBiffBounds; // Bounding rectangle of all cells
|
||
|
||
{ Index to the corresponding SHEET
|
||
record which is placed in the Workbook
|
||
globals stream. This index is formed by
|
||
TBiffSheet.Flush method and used by
|
||
TBiffWorkbook.Flush method to alter the
|
||
SHEET record after all sheets are written
|
||
to a BIFF stream. }
|
||
|
||
RecIndex: Integer;
|
||
|
||
constructor Create(Owner: TBiffWorkbook);
|
||
destructor Destroy; override;
|
||
|
||
//
|
||
// Adda a new cell to the list of cells.
|
||
//
|
||
|
||
procedure AddCell(Cell: TBiffCell);
|
||
|
||
{ Merges a rectangle area of cells }
|
||
|
||
procedure MergeCells(Rect: TRect);
|
||
|
||
//
|
||
// Adds a colinfo block to the list of colinfos
|
||
//
|
||
|
||
procedure AddColInfo(Info: TBiffColInfo);
|
||
|
||
{ Adds a new drawing to the sheet }
|
||
|
||
function AddDrawing: TEscherShape;
|
||
|
||
//
|
||
// This function is to be called at the very end
|
||
// to create a BIFF8 sheet substream.
|
||
//
|
||
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
{ Adds a page break }
|
||
|
||
procedure AddPageBreak(Row: LongInt);
|
||
|
||
{ Returns the index to the last row in this sheet.
|
||
If there're no rows, -1 is returned. }
|
||
|
||
function LastRowIndex: LongInt;
|
||
|
||
{ Column width is measured in 1/256 of width of the '0'
|
||
character written by the 0-th font specified in
|
||
the appropriate workbook. Row height is measured in twips.
|
||
|
||
1 point = 20 twips
|
||
|
||
When trying to read a non-existing column or a row, zero is
|
||
returned. When trying to change size of an inaccesible column
|
||
or a row (negative indexes, etc.), nothing is changed. }
|
||
|
||
property ColWidth[i: LongInt]: LongInt read GetColWidth write SetColWidth;
|
||
property RowHeight[i: LongInt]: LongInt read GetRowHeight write SetRowHeight;
|
||
|
||
property TextCellsCount: Integer read FStrCount;
|
||
property Visibility: TBiffSheetVisibility read FVis;
|
||
property Kind: TBiffSheetKind read FKind;
|
||
|
||
end;
|
||
|
||
{ BIFF workbook.
|
||
|
||
The workbook is an Excel document containing some information
|
||
and several sheets. The workbook is represented by class TBiffWorkbook.
|
||
An instance of this class can be accessed by multiple threads at a moment.
|
||
This is achieved via usage of critical section objects. }
|
||
|
||
TBiffWorkbook = class(TBiffObject)
|
||
private
|
||
|
||
{ Shared Strings Table }
|
||
|
||
SST: TObjList; // List of TBiffUCS
|
||
SSTHash: TListHashTable;
|
||
|
||
Win: TBiffWindow;
|
||
Sheets: TObjList; // List of TBiffSheet
|
||
Styles: TObjList; // List of TBiffStyle
|
||
FFormats: TObjList; // List of TBiffUCS
|
||
Escher: TEscherStorage; // Global Escher storage
|
||
FLinkTbl: TBiffLinkTable; // Contains external references; created on demand
|
||
|
||
{ Shared Fonts Table
|
||
|
||
First four FONT records are reserved
|
||
and have special meaning }
|
||
|
||
Fonts: TObjList; // List of TBiffFont
|
||
FontHash: TListHashTable;
|
||
|
||
{ Shared XFs Table
|
||
|
||
Any BIFF document must contain
|
||
at least 16 XF records used specially. }
|
||
|
||
XFs: TObjList; // List of TBiffXF
|
||
XFHash: TListHashTable;
|
||
|
||
{ Shared Colors Table
|
||
|
||
When anywhere a color is needed, this color
|
||
is placed to PALETTE record and index to
|
||
the color in the palette is used. Colors with
|
||
indexes 0..7 are built-in, colors with indexes
|
||
8..$3F are user defined.
|
||
|
||
PALETTE record may be omitted and then the
|
||
default Excel palette is used.
|
||
|
||
To add a color to the palette
|
||
use TboffWorkbook.AddColor method. }
|
||
|
||
Palette: array[0..BiffPaletteSize-1] of LongWord;
|
||
PalUsed: LongWord;
|
||
|
||
{ Optionally, the workbook can be encrypted }
|
||
|
||
FCipher: TBiffRC4;
|
||
|
||
{ The following critical section objects are used for
|
||
mutual access to different parts of a workbook. }
|
||
|
||
FCsStrings: TRTLCriticalSection;
|
||
FCsFonts: TRTLCriticalSection;
|
||
FCsXFs: TRTLCriticalSection;
|
||
FCsSheets: TRTLCriticalSection;
|
||
FCsStyles: TRTLCriticalSection;
|
||
FCsColors: TRTLCriticalSection;
|
||
FCsPictures: TRTLCriticalSection;
|
||
FCsFormats: TRTLCriticalSection;
|
||
|
||
{ TBiffWorkbook can be accesses by a few threads.
|
||
In this case, threads must synchronize access to
|
||
the shared workbook object. Here is a typical example
|
||
of use these functions:
|
||
|
||
<20> thread wants to add a string to a workbook
|
||
<20> thread calls TBiffWorkbook.LockSst
|
||
<20> thread adds a string via TBiffWorkbook.AddString
|
||
<20> thread calls TBiffWorkbook.UnlockSst
|
||
|
||
TBiffWorkbook performs these locks automatically, i.e.
|
||
client threads may not know about these. }
|
||
|
||
procedure LockSst;
|
||
procedure UnlockSst;
|
||
|
||
procedure LockFonts;
|
||
procedure UnlockFonts;
|
||
|
||
procedure LockXfs;
|
||
procedure UnlockXfs;
|
||
|
||
procedure LockSheets;
|
||
procedure UnlockSheets;
|
||
|
||
procedure LockStyles;
|
||
procedure UnlockStyles;
|
||
|
||
procedure LockColors;
|
||
procedure UnlockColors;
|
||
|
||
procedure LockPictures;
|
||
procedure UnlockPictures;
|
||
|
||
procedure LockFormats;
|
||
procedure UnlockFormats;
|
||
|
||
{ Internal methods }
|
||
|
||
function GetLinkTable: TBiffLinkTable;
|
||
function GetSheetsCount: LongInt;
|
||
function GetSheet(Index: LongInt): TBiffSheet;
|
||
function GetFontsCount: LongInt;
|
||
function GetFont(Index: LongInt): TBiffFont;
|
||
procedure SetFormat(i: TBiffFormatIndex; const s: WideString);
|
||
function AddBlip(Blip: TEscherPicture): LongInt;
|
||
function AddColorInternal(C: LongWord): LongInt;
|
||
|
||
public
|
||
|
||
constructor Create;
|
||
destructor Destroy; override;
|
||
|
||
{ Workbook can be protected with a password.
|
||
The password can contain up to 255 unicode characters. }
|
||
|
||
procedure SetPassword(const s: WideString);
|
||
|
||
{ BIFF8 contains all used strings in the SST table,
|
||
all cells with strings refers to the SST table.
|
||
If a cell needs to use a string, this function must be called.
|
||
|
||
Returns an SST index.
|
||
Multithread safe. }
|
||
|
||
function AddString(S: TBiffUCS): LongWord; overload;
|
||
function AddString(S: WideString): LongWord; overload;
|
||
|
||
{ In BIFF8 fonts have specific indexing: the 4-th FONT record
|
||
is omitted. Use this function to add a new font and receive
|
||
its valid index.
|
||
|
||
Returns a font index.
|
||
Multithread safe. }
|
||
|
||
function AddFont(F: TBiffFont): LongWord;
|
||
|
||
{ These routines add a specified kind of object to the workbook.
|
||
They are multithread safe. }
|
||
|
||
function AddXF(X: TBiffXF): LongWord;
|
||
function AddSheet(S: TBiffSheet): LongWord;
|
||
function AddStyle(S: TBiffStyle): LongInt;
|
||
function AddFormat(const FormatStr: WideString;
|
||
FormatIndex: TBiffFormatIndex = -1): TBiffFormatIndex;
|
||
|
||
{ Adds a color to the palette and returns an index to the
|
||
added color. If the color already exists, the index to
|
||
the existing color is returned. If the palette is full
|
||
and the color cannot be added, an index to the nearest color
|
||
is returned.
|
||
|
||
Byte structure of the color: RR GG BB AA
|
||
Multithread safe. }
|
||
|
||
function AddColor(C: LongWord): LongInt;
|
||
|
||
{ Adds a picture to the workbook.
|
||
AddBitmap is applicable for BMP, PNG, JPEG, TIFF, etc.
|
||
Multithread safe. }
|
||
|
||
function AddBitmap(Kind: TEscherBlipKind; Contents: TStream): LongInt;
|
||
function AddMetafile(Metafile: Graphics.TMetafile): LongInt;
|
||
|
||
{ Returns a count of strings occured in the workbook.
|
||
Identical strings are counted as much as they occur.
|
||
|
||
Multithread safe. }
|
||
|
||
function StringsCount: LongInt;
|
||
|
||
{ Writes the workbook to data stream in BIFF8 format. }
|
||
|
||
procedure Flush(Stream: TBiffStream); override;
|
||
|
||
{ The folowing properties are multithread safe. }
|
||
|
||
property SheetsCount: LongInt read GetSheetsCount;
|
||
property Sheet[Index: LongInt]: TBiffSheet read GetSheet;
|
||
|
||
property FontsCount: LongInt read GetFontsCount;
|
||
property Font[Index: LongInt]: TBiffFont read GetFont;
|
||
|
||
property Format[i: TBiffFormatIndex]: WideString write SetFormat;
|
||
|
||
property LinkTable: TBiffLinkTable read GetLinkTable;
|
||
|
||
end;
|
||
|
||
|
||
{ MS Excel treats only #10 character as
|
||
a line break, other characters (e.g. #13)
|
||
it displays as squares (unknown symbols).
|
||
|
||
This function deletes #13 chracaters.
|
||
Returns a new length of the string.
|
||
|
||
You must not use this function for an empty strings. }
|
||
|
||
procedure ValidateLineBreaks(var s: WideString);
|
||
|
||
{ Finds the nearest color within an array of colors. }
|
||
|
||
function NearestColor(Colors: Pointer; Count, Color: LongWord): LongWord;
|
||
|
||
implementation
|
||
|
||
uses
|
||
Math, frxClass;
|
||
|
||
{ This global variable is actually a static veriable of TBiffFormulaFuncList.
|
||
Delphi4 doesn't allow writing "class var FuncArray: ..." - that's why this var
|
||
is declared as global. However, when Delphi4 is left behind, this var should be
|
||
moved to the owner class. }
|
||
|
||
var
|
||
FuncArray: TBiffFormulaFuncArray;
|
||
|
||
//
|
||
// The following types describes structure
|
||
// of several specific BIFF records.
|
||
//
|
||
|
||
type
|
||
|
||
//
|
||
// BOF
|
||
//
|
||
|
||
TBiffrBOF = packed record
|
||
|
||
Version: Word;
|
||
Kind: Word;
|
||
Build: Word;
|
||
Year: Word;
|
||
Flags1: LongWord; // See BiffBoff values
|
||
Flags2: LongWord;
|
||
|
||
end;
|
||
|
||
//
|
||
// WINDOW1
|
||
// 16 bytes
|
||
//
|
||
|
||
TBiffrWindow = packed record
|
||
|
||
HPos: Word;
|
||
VPos: Word;
|
||
Width: Word;
|
||
Height: Word;
|
||
Flags: Word;
|
||
Active: Word; // Index to active worksheet
|
||
First: Word; // Index of first visible tab
|
||
Sel: Word; // Number of selected worksheets
|
||
TabW: Word; // Width of the tabbar in 1/1000 of window width
|
||
|
||
end;
|
||
|
||
//
|
||
// FONT
|
||
// 14+ bytes
|
||
// See docs for complete information
|
||
//
|
||
|
||
TBiffrFont = packed record
|
||
|
||
Height: Word; // Height in 1/20 point
|
||
Opts: Word; // Option flags, see TBiffFontOptions
|
||
Color: Word; // Color index
|
||
Weight: Word; // Weight in range 100..1000.
|
||
Esc: Word; // Escapement, see TBiffFontEscapement
|
||
Under: Byte; // Underline, see TBiffFontUnderline
|
||
Family: Byte; // Font family, see TBiffFontFamily
|
||
CharSet: Byte;
|
||
NotUsed: Byte;
|
||
|
||
{
|
||
Name: Unicode 16-bit length string
|
||
}
|
||
|
||
end;
|
||
|
||
//
|
||
// XF
|
||
// 20 bytes
|
||
//
|
||
|
||
TBiffrXF = packed record
|
||
|
||
Font: Word;
|
||
Format: Word;
|
||
Style: Word; // For bits 0-2 see TBiffXFTypeProt
|
||
Align: Byte; // See TBiffXFHAlign and TBiffXFVAlign
|
||
Rotation: Byte;
|
||
Indent: Byte;
|
||
UsedAttrs:Byte; // See TBiffXFUsedAttrib
|
||
BStyle1: LongWord; // 0-3 bytes of border style
|
||
BStyle2: LongWord; // 4-7 bytes of border style
|
||
Pattern: Word;
|
||
|
||
end;
|
||
|
||
TBiffrBuiltinStyle = packed record
|
||
|
||
XF: Word; // 15-th bit is 1
|
||
Id: Byte; // See TBiffBuiltinStyleId
|
||
Level: Byte;
|
||
|
||
end;
|
||
|
||
//
|
||
// SHEET
|
||
// 6+ bytes
|
||
// See docs for complete information
|
||
//
|
||
|
||
TBiffrSheet = packed record
|
||
|
||
Offset: LongWord; // Offset to BOF record
|
||
Vis: Byte; // See TBiffSheetVisibility
|
||
Kind: Byte; // See TBiffSheetKind
|
||
|
||
{
|
||
Name: Unicode 8-bit length string
|
||
}
|
||
|
||
end;
|
||
|
||
//
|
||
// DIMENSION
|
||
// 14 bytes
|
||
//
|
||
|
||
TBiffrDimension = packed record
|
||
|
||
FirstRow: LongWord;
|
||
LastRow: LongWord; // Increased by 1
|
||
FirstCol: Word;
|
||
LastCol: Word; // Increased by 1
|
||
NotUsed: Word;
|
||
|
||
end;
|
||
|
||
//
|
||
// WINDOW2
|
||
// 18 bytes
|
||
//
|
||
|
||
TBiffrWindow2 = packed record
|
||
|
||
Options: Word; // See TBiffWindowOptions
|
||
FirstRow: Word; // First visible row
|
||
FirstCol: Word; // First visible column
|
||
GridCol: Word; // Color index of grid lines
|
||
NotUsed1: Word;
|
||
CMFPBV: Word; // Can be 0
|
||
CMFNV: Word; // Can be 0
|
||
NotUsed2: LongWord;
|
||
|
||
end;
|
||
|
||
//
|
||
// ROW
|
||
// 16 bytes
|
||
//
|
||
|
||
TBiffrRow = packed record
|
||
|
||
Row: Word;
|
||
FirstCol: Word;
|
||
LastCol: Word; // Increased by 1
|
||
Height: Word; // See docs
|
||
NotUsed: Word;
|
||
NotUsed2: Word;
|
||
Format: LongWord; // See docs
|
||
|
||
end;
|
||
|
||
//
|
||
// SST
|
||
// 8+ bytes
|
||
//
|
||
|
||
TBiffrSST = packed record
|
||
|
||
WBSCount: LongWord;
|
||
SSTCount: LongWord;
|
||
|
||
{
|
||
UCS16 strings
|
||
}
|
||
|
||
end;
|
||
|
||
//
|
||
// BLANK
|
||
//
|
||
|
||
TBiffrBlank = packed record
|
||
|
||
Row: Word;
|
||
Column: Word;
|
||
XF: Word;
|
||
|
||
end;
|
||
|
||
PBiffrBlank = ^TBiffrBlank;
|
||
|
||
//
|
||
// FORMULA
|
||
// [MS-XLS] 2.4.127
|
||
//
|
||
|
||
TBiffrFormula = packed record
|
||
|
||
Cell: TBiffrBlank;
|
||
Value: Double;
|
||
Flags: Word; // set to 0
|
||
Cache: Cardinal; // set to 0
|
||
InstLen: Word; // size in bytes of formula's program
|
||
|
||
end;
|
||
|
||
//
|
||
// LABELSST
|
||
//
|
||
|
||
TBiffrLabelSST = packed record
|
||
|
||
Row: Word;
|
||
Column: Word;
|
||
XF: Word;
|
||
SSTIndex: LongWord;
|
||
|
||
end;
|
||
|
||
PBiffrLabelSST = ^TBiffrLabelSST;
|
||
|
||
//
|
||
// NUMBER
|
||
//
|
||
|
||
TBiffrNumber = packed record
|
||
|
||
Row: Word;
|
||
Column: Word;
|
||
XF: Word;
|
||
Value: Double; // IEEE 754 floating-point value (64-bit double precision)
|
||
|
||
end;
|
||
|
||
PBiffrNumber = ^TBiffrNumber;
|
||
|
||
//
|
||
// RK
|
||
//
|
||
|
||
TBiffrRK = packed record
|
||
|
||
Row: Word;
|
||
Column: Word;
|
||
XF: Word;
|
||
RK: LongWord;
|
||
|
||
end;
|
||
|
||
PBiffrRK = ^TBiffrRK;
|
||
|
||
//
|
||
// COLINFO
|
||
// 12 bytes
|
||
//
|
||
|
||
TBiffrColInfo = packed record
|
||
|
||
First: Word;
|
||
Last: Word;
|
||
Width: Word;
|
||
XF: Word;
|
||
Options: Word;
|
||
Reserved: Word;
|
||
|
||
end;
|
||
|
||
//
|
||
// Cells block
|
||
// 8 bytes
|
||
// Used by MERGEDCELLS record
|
||
//
|
||
|
||
TBiffrCellsBlock = packed record
|
||
|
||
FR: Word; // Index to first row
|
||
LR: Word; // Index to last row
|
||
FC: Word; // Index to first column
|
||
LC: Word; // Index to last column
|
||
|
||
end;
|
||
|
||
//
|
||
// PAGESETUP
|
||
// 34 bytes
|
||
//
|
||
|
||
TBiffrPageSetup = packed record
|
||
|
||
Size: Word; // See docs for the list of available values
|
||
Scaling: Word; // In percents
|
||
StartNum: Word; // Start page number
|
||
Width: Word; // 0 = use default
|
||
Height: Word; // 0 = use default
|
||
Options: Word;
|
||
Xdpi: Word;
|
||
Ydpi: Word;
|
||
Header: Double; // Header margin in inches
|
||
Footer: Double; // Footer margin in inches
|
||
Copies: Word; // Number of copies to print
|
||
|
||
end;
|
||
|
||
TPackedRect = packed record
|
||
|
||
Left: LongInt;
|
||
Top: LongInt;
|
||
Right: LongInt;
|
||
Bottom: LongInt;
|
||
|
||
end;
|
||
|
||
//
|
||
// Common Object Record
|
||
// 22 bytes
|
||
//
|
||
|
||
TBiffrCOR = packed record
|
||
|
||
Kind: Word; // See BiffGo values
|
||
Id: Word; // Object Id
|
||
Opts: Word;
|
||
Unused1: array[1..16] of Byte;
|
||
|
||
end;
|
||
|
||
{ RC4 encryption header
|
||
52 bytes }
|
||
|
||
TBiffrRC4 = packed record
|
||
|
||
Version: LongWord; // Must be $00010001
|
||
Salt: array[1..16] of Byte;
|
||
Verifier: array[1..16] of Byte;
|
||
Hash: array[1..16] of Byte;
|
||
|
||
end;
|
||
|
||
{$IFDEF DELPHI16}
|
||
frxCardinal = UInt64;
|
||
{$ELSE}
|
||
frxCardinal = {$IFDEF FPC}Cardinal{$ELSE}Cardinal{$ENDIF};
|
||
{$ENDIF}
|
||
|
||
const
|
||
|
||
//
|
||
// Graphics object types
|
||
//
|
||
|
||
BiffGoPicture = 8;
|
||
|
||
//
|
||
// The following constants are BIFF record types,
|
||
// i.e. TBiffRecord.Id value.
|
||
//
|
||
|
||
BiffIdFormula = $0006; // FORMULA
|
||
BiffIdRString = $00d6; // RSTRING
|
||
BiffIdRK = $027E; // RK
|
||
BiffIdNumber = $0203; // NUMBER
|
||
BiffIdMulRK = $00Bd; // MULRK
|
||
BiffIdMulBlank = $00BE; // MULBLANK
|
||
BiffIdLabelSST = $00Fd; // LABELSST
|
||
BiffIdBOF = $0809; // BOF
|
||
BiffIdWindow = $003d; // WINDOW1
|
||
BiffIdFont = $0031; // FONT
|
||
BiffIdXF = $00E0; // XF
|
||
BiffIdStyle = $0293; // STYLE
|
||
BiffIdSheet = $0085; // SHEET
|
||
BiffIdEOF = $000A; // EOF
|
||
BiffIdDim = $0200; // DIMENSION
|
||
BiffIdWindow2 = $023E; // WINDOW2
|
||
BiffIdRow = $0208; // ROW
|
||
BiffIdDBCell = $00d7; // DBCELL
|
||
BiffIdContinue = $003C; // CONTINUE
|
||
BiffIdBlank = $0201; // BLANK
|
||
BiffIdBoolErr = $0205; // BOOLERR
|
||
BiffIdLabel = $0204; // LABEL
|
||
BiffIdSST = $00FC; // SST
|
||
BiffIdPalette = $0092; // PALETTE
|
||
BiffIdColInfo = $007d; // COLINFO
|
||
BiffIdMergedCells = $00E5; // MERGEDCELLS
|
||
BiffIdLeftMargin = $0026; // LEFTMARGIN
|
||
BiffIdRightMargin = $0027; // RIGHTMARGIN
|
||
BiffIdTopMargin = $0028; // TOPMARGIN
|
||
BiffIdBottomMargin = $0029; // BOTTOMMARGIN
|
||
BiffIdPageSetup = $00a1; // PAGESETUP
|
||
BiffIdFormat = $041e; // FORMAT
|
||
BiffIdEscher = $00eb; // ESCHER
|
||
BiffIdDrawing = $00ec; // DRAWING
|
||
BiffIdGObj = $005d; // GOBJ
|
||
BiffIdCOR = $0015; // Common Object Record
|
||
BiffIdHorPageBreak = $001b; // HORIZONTALPAGEBREAK
|
||
BiffIdFilePass = $002f; // FILEPASS
|
||
BiffIdUserExcl = $0194; // USEREXCL
|
||
BiffIdFileLock = $0195; // FILELOCK
|
||
BiffIdInterfaceHdr = $00e1; // INTERFACEHDR
|
||
BiffIdRRDInfo = $0196; // RRDINFO
|
||
BiffIdRRDHead = $0138; // RRDHEAD
|
||
BiffIdInterfaceEnd = $00e2; // INTERFACEEND
|
||
BiffIdMms = $00c1; // MMS
|
||
BiffIdWriteAccess = $005c; // WRITEACCESS
|
||
BiffIdCodepage = $0042; // CODEPAGE
|
||
BiffIdDsf = $0161; // DSF
|
||
BiffIdRrd = $013d; // RRD
|
||
BiffIdWinProt = $0019; // WINPROT
|
||
BiffIdProt = $0012; // PROTECT
|
||
BiffIdPassword = $0013; // PASSWORD
|
||
BiffIdProtRev = $01af; // PROTREV
|
||
BiffIdProtRevPass = $01bc; // PROTREVPASS
|
||
BiffIdBackup = $0040; // BACKUP
|
||
BiffIdHideObj = $008d; // HIDEOBJ
|
||
BiffIdDate1904 = $0022; // DATE1904
|
||
BiffIdCalcPrec = $000e; // CALCPRECISION
|
||
BiffIdRefreshAll = $01b7; // REFRESHALL
|
||
BiffIdBookBool = $00da; // BOOKBOOL
|
||
BiffIdUserElf = $0160; // USERELF
|
||
BiffIdCountry = $008c; // COUNTRY
|
||
BiffIdExtSst = $00ff; // EXTSST
|
||
BiffIdCalcMode = $000d; // CALCMODE
|
||
BiffIdCalcCount = $000c; // CALCCOUNT
|
||
BiffIdCalcRefMode = $000f; // CALCREFMODE
|
||
BiffIdCalcIter = $0011; // CALCITER
|
||
BiffIdCalcDelta = $0010; // CALCDELTA
|
||
BiffIdSaveRecalc = $005f; // SAVERECALC
|
||
BiffIdPrintRowCol = $002a; // PRINTROWCOL
|
||
BiffIdPrintGrid = $002b; // PRINTGRID
|
||
BiffIdGridSet = $0082; // GRIDSET
|
||
BiffIdGuts = $0080; // GUTS
|
||
BiffIdDefRowHeight = $0225; // DEFROWHEIGHT
|
||
BiffIdWsBool = $0081; // WSBOOL
|
||
BiffIdHeader = $0014; // HEADER
|
||
BiffIdFooter = $0015; // FOOTER
|
||
BiffIdHCenter = $0083; // HCENTER
|
||
BiffIdVCenter = $0084; // VCENTER
|
||
BiffIdDefColWidth = $0055; // DEFCOLWIDTH
|
||
BiffIdExtBook = $01ae; // EXTERNALBOOK
|
||
BiffIdExtSheet = $0017; // EXTERNALSHEET
|
||
|
||
function NearestColor(Colors: Pointer; Count, Color: LongWord): LongWord;
|
||
|
||
function Dist(i, c: LongWord): LongWord;
|
||
var
|
||
j: Integer;
|
||
begin
|
||
c := c xor PLongWord(LongWord(Colors) + i*SizeOf(Color))^;
|
||
Result := 0;
|
||
|
||
for j := 1 to 4 do
|
||
begin
|
||
Inc(Result, c and $ff);
|
||
c := c shr 8;
|
||
end;
|
||
end;
|
||
|
||
var
|
||
i: Integer;
|
||
begin
|
||
Result := 0;
|
||
|
||
for i := 0 to Count - 1 do
|
||
if Dist(i, Color) < Dist(Result, Color) then
|
||
Result := i;
|
||
end;
|
||
|
||
{ Sets or resets the N-th bit of a variable }
|
||
|
||
procedure SetBit(P: Pointer; N: Cardinal; V: Boolean);
|
||
var
|
||
B: PByte;
|
||
M: Byte;
|
||
begin
|
||
B := PByte(frxCardinal(P) + N div 8);
|
||
M := 1 shl (N mod 8);
|
||
|
||
if V then
|
||
B^ := B^ or M
|
||
else
|
||
B^ := B^ and not M
|
||
end;
|
||
|
||
procedure ValidateLineBreaks(var s: WideString);
|
||
var
|
||
i, j: Cardinal;
|
||
begin
|
||
j := 1;
|
||
|
||
for i := 1 to Length(s) do
|
||
if s[i] <> #13 then
|
||
begin
|
||
s[j] := s[i];
|
||
Inc(j);
|
||
end;
|
||
|
||
SetLength(s, j - 1);
|
||
end;
|
||
|
||
{ TBiffObject }
|
||
|
||
class procedure TBiffObject.FlushList(list: TObjList; Stream: TBiffStream);
|
||
var
|
||
i: LongInt;
|
||
begin
|
||
for i := 0 to list.Count - 1 do
|
||
TBiffObject(list[i]).Flush(Stream);
|
||
end;
|
||
|
||
function TBiffObject.GetHashCode: LongInt;
|
||
begin
|
||
Result := 0;
|
||
end;
|
||
|
||
function TBiffObject.Equals(s: TBiffObject): Boolean;
|
||
begin
|
||
Result := Self = s;
|
||
end;
|
||
|
||
{ TBiffRC4 }
|
||
|
||
constructor TBiffRC4.Create;
|
||
var
|
||
r: array[1..4] of LongWord;
|
||
i: LongInt;
|
||
g: TCryptoCMWC;
|
||
begin
|
||
FCipher := TCryptoRC4.Create;
|
||
g := TCryptoCMWC.Create;
|
||
|
||
for i := 1 to 4 do
|
||
r[i] := g.Next;
|
||
|
||
Move(r, FSalt, 16);
|
||
|
||
for i := 1 to 4 do
|
||
r[i] := g.Next;
|
||
|
||
Move(r, FVerifier, 16);
|
||
|
||
g.Free;
|
||
end;
|
||
|
||
destructor TBiffRC4.Destroy;
|
||
begin
|
||
FCipher.Free;
|
||
end;
|
||
|
||
procedure TBiffRC4.MD5(out Hash; const Data; Size: Integer);
|
||
begin
|
||
TCryptoHash.Hash('MD5', Hash, 16, Data, Size);
|
||
end;
|
||
|
||
procedure TBiffRC4.Prepare(const Password; PassLen: Integer);
|
||
var
|
||
h: array[1..16] of Byte;
|
||
b: array[1..336] of Byte;
|
||
i: LongInt;
|
||
begin
|
||
MD5(h, Password, PassLen);
|
||
|
||
Move(h, b, 5);
|
||
Move(FSalt, b[6], 16);
|
||
|
||
for i := 1 to 15 do
|
||
Move(b, b[1 + 21 * i], 21);
|
||
|
||
MD5(h, b, 336);
|
||
Move(h, FTruncHash, 5);
|
||
|
||
Initialize(0);
|
||
MD5(FHash, FVerifier, 16);
|
||
Encrypt(@FVerifier, 16);
|
||
Encrypt(@FHash, 16);
|
||
end;
|
||
|
||
procedure TBiffRC4.Init(Key: Pointer; Len: LongInt);
|
||
begin
|
||
FCipher.Init(Key^, Len);
|
||
end;
|
||
|
||
procedure TBiffRC4.Initialize(BlockId: LongWord);
|
||
var
|
||
h: array[1..9] of Byte;
|
||
k: array[1..16] of Byte;
|
||
begin
|
||
Move(FTruncHash, h, 5);
|
||
Move(BlockId, h[6], 4);
|
||
MD5(k, h, 9);
|
||
Init(@k, 16);
|
||
|
||
FTail := 1024;
|
||
FBlockId := BlockId;
|
||
end;
|
||
|
||
procedure TBiffRC4.Encrypt(Data: Pointer; Size: LongInt); cdecl;
|
||
begin
|
||
FCipher.Encrypt(Data, Size);
|
||
end;
|
||
|
||
procedure TBiffRC4.EncryptEx(Data: Pointer; Size: LongInt);
|
||
var
|
||
n: LongInt;
|
||
begin
|
||
{ If the data block fits to the current 1024-bytes block,
|
||
encrypt the data and exit. }
|
||
|
||
if Size <= FTail then
|
||
begin
|
||
Encrypt(Data, Size);
|
||
Dec(FTail, Size);
|
||
if FTail = 0 then
|
||
Initialize(FBlockId + 1);
|
||
|
||
Exit;
|
||
end;
|
||
|
||
{ If the data block does not fit the current 1024-bytes block,
|
||
it must be encrypted by parts. Firstly, encrypt a part of
|
||
the data that fits the current 1024-bytes block. }
|
||
|
||
Encrypt(Data, FTail);
|
||
if Data <> nil then Data := Pointer(frxInteger(Data) + FTail);
|
||
Dec(Size, FTail);
|
||
Initialize(FBlockId + 1);
|
||
|
||
{ Split the data into 1024-bytes blocks and encrypt them
|
||
consequently. At the beginning of each 1024-bytes block,
|
||
the RC4 cipher must be reinitialized using the index to
|
||
the current 1024-bytes block. }
|
||
|
||
while Size > 0 do
|
||
begin
|
||
n := Size;
|
||
if n > FTail then n := FTail;
|
||
Encrypt(Data, n);
|
||
Dec(Size, n);
|
||
Dec(FTail, n);
|
||
|
||
if Data <> nil then
|
||
Data := Pointer(frxInteger(Data) + n);
|
||
|
||
if FTail = 0 then
|
||
Initialize(FBlockId + 1);
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffRC4.EncryptStream(Stream: TBiffStream);
|
||
|
||
function GetSkipSize(RecId: TBiffRecId; RecSize: Cardinal): Cardinal;
|
||
begin
|
||
case RecId of
|
||
BiffIdFilePass,
|
||
BiffIdUserExcl,
|
||
BiffIdFileLock,
|
||
BiffIdInterfaceHdr,
|
||
BiffIdRRDInfo,
|
||
BiffIdRRDHead,
|
||
BiffIdBOF:
|
||
Result := RecSize;
|
||
|
||
BiffIdSheet:
|
||
Result := 4;
|
||
|
||
else
|
||
Result := 0;
|
||
end;
|
||
end;
|
||
|
||
var
|
||
i: LongInt;
|
||
n: LongWord;
|
||
RecData: TMemoryStream;
|
||
begin
|
||
Initialize(0);
|
||
RecData := TMemoryStream.Create;
|
||
|
||
try
|
||
for i := 0 to Stream.Count - 1 do
|
||
with Stream[i] do
|
||
begin
|
||
n := GetSkipSize(Id, Size);
|
||
|
||
RecData.Position := 0;
|
||
SaveToStream(RecData);
|
||
|
||
EncryptEx(nil, 4 + n); // 4 byte header and a few first bytes are not encrypted
|
||
EncryptEx(Pointer(frxCardinal(RecData.Memory) + n), Size - n);
|
||
|
||
RecData.Position := 0;
|
||
LoadFromStream(RecData);
|
||
end;
|
||
finally
|
||
RecData.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffRC4.Flush(Stream: TBiffStream);
|
||
var
|
||
r: TBiffrRC4;
|
||
begin
|
||
ZeroMemory(@r, SizeOf(r));
|
||
|
||
r.Version := $00010001;
|
||
Move(FSalt, r.Salt, 16);
|
||
Move(FVerifier, r.Verifier, 16);
|
||
Move(FHash, r.Hash, 16);
|
||
|
||
with Stream.Add(BiffIdFilePass) do
|
||
begin
|
||
WriteConst(1, 2);
|
||
Write(r, SizeOf(r));
|
||
end;
|
||
end;
|
||
|
||
{ TBiffWindow2 }
|
||
|
||
constructor TBiffWindow2.Create;
|
||
begin
|
||
Options := BiffWoGridLines or BiffWoHeaders or BiffWoZeros or
|
||
BiffWoAutoGridColor or BiffWoOutline or {BiffWoSelected or}
|
||
BiffWoActive;
|
||
|
||
{ There are only 64 colors in the palette.
|
||
The following assignment emphasizes the fact
|
||
that the grid color is selected automatically }
|
||
|
||
GridCol := 64;
|
||
end;
|
||
|
||
procedure TBiffWindow2.Flush(Stream: TBiffStream);
|
||
var
|
||
r: TBiffrWindow2;
|
||
begin
|
||
ZeroMemory(@r, SizeOf(r));
|
||
|
||
r.Options := Options;
|
||
r.FirstRow := FirstRow;
|
||
r.FirstCol := FirstCol;
|
||
r.GridCol := GridCol;
|
||
r.CMFPBV := MFPBP;
|
||
r.CMFNV := CMFNV;
|
||
|
||
Stream.Add(BiffIdWindow2).Write(r, SizeOf(r));
|
||
end;
|
||
|
||
{ TBiffPageSetup }
|
||
|
||
constructor TBiffPageSetup.Create;
|
||
begin
|
||
Size := BiffPsA4;
|
||
Orient := bpoPortrait;
|
||
Colored := True;
|
||
Xdpi := 300;
|
||
Ydpi := 300;
|
||
Copies := 1;
|
||
end;
|
||
|
||
procedure TBiffPageSetup.Flush(Stream: TBiffStream);
|
||
var
|
||
r: TBiffrPageSetup;
|
||
o: PWord;
|
||
begin
|
||
ZeroMemory(@r, SizeOf(r));
|
||
|
||
r.Scaling := 100;
|
||
r.Size := Size;
|
||
r.StartNum := 0;
|
||
r.Width := 1;
|
||
r.Height := 1;
|
||
r.Xdpi := Xdpi;
|
||
r.Ydpi := Ydpi;
|
||
r.Header := 0.0;
|
||
r.Footer := 0.0;
|
||
r.Copies := Word(Copies);
|
||
r.Options := 0;
|
||
|
||
o := @r.Options;
|
||
|
||
SetBit(o, 0, PrintInRows);
|
||
SetBit(o, 1, Orient = bpoPortrait);
|
||
SetBit(o, 3, not Colored);
|
||
SetBit(o, 4, Draft);
|
||
SetBit(o, 5, CellNotes);
|
||
SetBit(o, 7, True);
|
||
SetBit(o, 9, SheetNotes);
|
||
SetBit(o, 10, True); // Do not print errors
|
||
|
||
Stream.Add(BiffIdPageSetup).Write(r, SizeOf(r));
|
||
end;
|
||
|
||
{ TBiffNumberCell }
|
||
|
||
procedure TBiffNumberCell.Flush(Stream: TBiffStream);
|
||
var
|
||
r: TBiffrNumber;
|
||
begin
|
||
ZeroMemory(@r, SizeOf(r));
|
||
|
||
r.Row := Row;
|
||
r.Column := Col;
|
||
r.XF := XF;
|
||
r.Value := Value;
|
||
|
||
Stream.Add(BiffIdNumber).Write(r, SizeOf(r));
|
||
end;
|
||
|
||
constructor TBiffNumberCell.Create(Value: Double);
|
||
begin
|
||
Self.Value := Value;
|
||
end;
|
||
|
||
{ TBiffStyle }
|
||
|
||
constructor TBiffStyle.Create;
|
||
begin
|
||
Level := -1;
|
||
end;
|
||
|
||
procedure TBiffStyle.Flush(Stream: TBiffStream);
|
||
var
|
||
bs: TBiffrBuiltinStyle;
|
||
ucs: TBiffUCS;
|
||
begin
|
||
ZeroMemory(@bs, SizeOf(bs));
|
||
|
||
//
|
||
// Built-in style
|
||
//
|
||
|
||
if Name = '' then
|
||
begin
|
||
bs.XF := XF or $8000;
|
||
bs.Id := StyleId;
|
||
bs.Level := Byte(Level);
|
||
|
||
Stream.Add(BiffIdStyle).Write(bs, SizeOf(bs));
|
||
Exit;
|
||
end;
|
||
|
||
//
|
||
// User defined style
|
||
//
|
||
|
||
Stream.Add(BiffIdStyle).Write(XF, 2);
|
||
|
||
ucs := TBiffucs.Create(Name, True);
|
||
ucs.Flush(Stream);
|
||
ucs.Free;
|
||
end;
|
||
|
||
{ TBiffColInfo }
|
||
|
||
constructor TBiffColInfo.Create(Column, XF, Width: LongInt);
|
||
begin
|
||
First := Column;
|
||
Last := Column;
|
||
Self.XF := XF;
|
||
Self.Width:= Width;
|
||
Hidden := False;
|
||
Collapsed := False;
|
||
Outline := 0;
|
||
end;
|
||
|
||
procedure TBiffColInfo.Flush(Stream: TBiffStream);
|
||
var
|
||
R: TBiffrColInfo;
|
||
begin
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
R.First := First;
|
||
R.Last := Last;
|
||
R.Width := Width;
|
||
R.XF := XF;
|
||
R.Options := 0;
|
||
|
||
SetBit(@R.Options, 0, Hidden);
|
||
SetBit(@R.Options, 12, Collapsed);
|
||
R.Options := R.Options and ((7 and Outline) shl 8);
|
||
|
||
Stream.Add(BiffIdColInfo).Write(R, SizeOf(R));
|
||
end;
|
||
|
||
{ TBiffWindow }
|
||
|
||
constructor TBiffWindow.Create;
|
||
begin
|
||
HPos := 0;
|
||
VPos := 0;
|
||
Width := 15600;
|
||
Height := 8190;
|
||
ActiveSheet := 0;
|
||
FirstTab := 0;
|
||
SelSheet := 1;
|
||
TabWidth := 400;
|
||
|
||
Visible := True;
|
||
Open := True;
|
||
HSBVisible := True;
|
||
VSBVisible := True;
|
||
TabVisible := True;
|
||
end;
|
||
|
||
procedure TBiffWindow.Flush(Stream: TBiffStream);
|
||
var
|
||
R: TBiffrWindow;
|
||
F: Word;
|
||
begin
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
R.HPos := HPos;
|
||
R.VPos := VPos;
|
||
R.Width := Width;
|
||
R.Height := Height;
|
||
R.Active := ActiveSheet;
|
||
R.First := FirstTab;
|
||
R.Sel := SelSheet;
|
||
R.TabW := TabWidth;
|
||
|
||
F := 0;
|
||
|
||
SetBit(@F, 0, not Visible);
|
||
SetBit(@F, 1, not Open);
|
||
SetBit(@F, 3, HSBVisible);
|
||
SetBit(@F, 4, VSBVisible);
|
||
SetBit(@F, 5, TabVisible);
|
||
|
||
F := 56;
|
||
R.Flags := F;
|
||
Stream.Add(BiffIdWindow).Write(R, SizeOf(R));
|
||
end;
|
||
|
||
{ TBiffCell }
|
||
|
||
constructor TBiffCell.Create;
|
||
begin
|
||
XF := 15; // default XF for cells
|
||
end;
|
||
|
||
procedure TBiffCell.Flush(Stream: TBiffStream);
|
||
var
|
||
R: TBiffrBlank;
|
||
begin
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
R.Row := Row;
|
||
R.Column := Col;
|
||
R.XF := XF;
|
||
|
||
with Stream.Add(BiffIdBlank) do
|
||
Write(R, SizeOf(R));
|
||
end;
|
||
|
||
{ TBiffTextCell }
|
||
|
||
constructor TBiffTextCell.Create(SST: LongInt);
|
||
begin
|
||
inherited Create;
|
||
Self.SST := SST;
|
||
end;
|
||
|
||
procedure TBiffTextCell.Flush(Stream: TBiffStream);
|
||
var
|
||
R: TBiffrLabelSST;
|
||
begin
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
R.Row := Row;
|
||
R.Column := Col;
|
||
R.XF := XF;
|
||
R.SSTIndex := SST;
|
||
|
||
Stream.Add(BiffIdLabelSST).Write(R, SizeOf(R));
|
||
end;
|
||
|
||
{ TBiffFont }
|
||
|
||
constructor TBiffFont.Create;
|
||
begin
|
||
with Data do
|
||
begin
|
||
Weight := Word(fwNormal);
|
||
Name := 'Arial';
|
||
Color := Word(ciBlack);
|
||
Height := 12*20;
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFont.Flush(Stream: TBiffStream);
|
||
var
|
||
R: TBiffrFont;
|
||
begin
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
with Data do
|
||
begin
|
||
{ Font height must be zero or in bounds [20, 8191].
|
||
Required by [MS-XLS] Section 2.4.122. }
|
||
|
||
if Height < 20 then
|
||
R.Height := 0
|
||
else if Height > 8191 then
|
||
R.Height := 8191
|
||
else
|
||
R.Height := Height;
|
||
|
||
R.Opts := Options;
|
||
R.Color := Color;
|
||
R.Weight := Weight;
|
||
R.Esc := Word(Esc);
|
||
R.Under := Byte(Underline);
|
||
R.Family := Byte(Family);
|
||
R.CharSet := Charset;
|
||
end;
|
||
|
||
Stream.Add(BiffIdFont).Write(R, SizeOf(R));
|
||
|
||
with TBiffUCS.Create(Name, False) do
|
||
try
|
||
Compress := False;
|
||
Flush(Stream);
|
||
finally
|
||
Free;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFont.Equals(Font: TBiffObject): Boolean;
|
||
begin
|
||
Result := GetHashCode = Font.GetHashCode;
|
||
end;
|
||
|
||
function TBiffFont.GetHashCode: Integer;
|
||
var
|
||
H: TCryptoHash;
|
||
begin
|
||
if Hash = 0 then
|
||
begin
|
||
H := TCryptoJenkins.Create;
|
||
|
||
try
|
||
H.Push(Data, SizeOf(Data));
|
||
|
||
if Name <> '' then
|
||
H.Push(Name[1], SizeOf(Name[1]) * Length(Name));
|
||
|
||
H.GetDigest(Hash, SizeOf(Hash));
|
||
finally
|
||
H.Free;
|
||
end;
|
||
end;
|
||
|
||
Result := Hash;
|
||
end;
|
||
|
||
function TBiffFont.StrWidth(const Str: WideString): LongInt;
|
||
var
|
||
dc: HDC; // HDC
|
||
font: HFONT; // HFONT
|
||
fam: LongWord; // Font family
|
||
sz: SIZE; // String size
|
||
begin
|
||
with Data do
|
||
begin
|
||
Result := 0;
|
||
|
||
dc := CreateDC('DISPLAY', nil, nil, nil);
|
||
if dc = 0 then
|
||
Exit;
|
||
|
||
case Family of
|
||
ffRoman: fam := FF_ROMAN;
|
||
ffSwiss: fam := FF_SWISS;
|
||
ffModern: fam := FF_MODERN;
|
||
ffScript: fam := FF_SCRIPT;
|
||
ffDecorative: fam := FF_DECORATIVE;
|
||
else fam := FF_DONTCARE;
|
||
end;
|
||
|
||
font := CreateFontW(
|
||
Height div 10, // Height in logical units
|
||
0, // Width in logical units
|
||
0, // Escapement in 1/10 of a degree
|
||
0, // Orientation in 1/10 of a degree
|
||
Weight, // Font weight
|
||
|
||
//
|
||
// Flags: italic, underline, struck out
|
||
//
|
||
|
||
Word(foItalic) and Options,
|
||
LongWord(Underline <> fuNone),
|
||
Word(foStruckOut) and Options,
|
||
|
||
Charset, // Font charset
|
||
OUT_DEFAULT_PRECIS, // Output precision
|
||
CLIP_DEFAULT_PRECIS, // Clip precision
|
||
DEFAULT_QUALITY, // Output quality
|
||
fam, // Font family
|
||
PWideChar(Name)); // Font name
|
||
|
||
if font = 0 then
|
||
begin
|
||
DeleteDC(dc);
|
||
Exit;
|
||
end;
|
||
|
||
SelectObject(dc, font);
|
||
|
||
if GetTextExtentPoint32W(dc, PWideChar(Str), Length(Str), sz) then
|
||
Result := sz.cx;
|
||
|
||
DeleteObject(font);
|
||
DeleteDC(dc);
|
||
end;
|
||
end;
|
||
|
||
{ TBiffXF }
|
||
|
||
constructor TBiffXF.Create;
|
||
begin
|
||
Data.Parent := $FFF;
|
||
Data.HAlign := xfhaLeft;
|
||
Data.VAlign := xfvaTop;
|
||
Data.WordWrap := True;
|
||
Data.Prot := Byte(xftpCellLocked);
|
||
end;
|
||
|
||
procedure TBiffXF.Flush(Stream: TBiffStream);
|
||
var
|
||
X: TBiffrXF;
|
||
begin
|
||
ZeroMemory(@X, SizeOf(X));
|
||
|
||
with Data do
|
||
begin
|
||
X.Font := Font;
|
||
X.Format := Format;
|
||
X.Style := Prot and 7 or (Parent shl 4);
|
||
X.Rotation := Rotation;
|
||
X.UsedAttrs := Byte(UsedAttrs shl 2);
|
||
|
||
if (Prot and xftpStyle) <> 0 then
|
||
X.UsedAttrs := not X.UsedAttrs;
|
||
|
||
X.Align :=
|
||
$03 and Byte(HAlign) or
|
||
$08 and (Byte(WordWrap) shl 3) or
|
||
$70 and (Byte(VAlign) shl 4) or
|
||
$80 and (Byte(Justify) shl 7);
|
||
|
||
X.Indent :=
|
||
$0f and Indent or
|
||
$10 and (Byte(Shrink) shl 4) or
|
||
$c0 and (Byte(Direction) shl 6);
|
||
|
||
X.BStyle1 :=
|
||
$0000000f and LongWord(L.Style) or
|
||
$000000f0 and (LongWord(R.Style) shl 4) or
|
||
$00000f00 and (LongWord(T.Style) shl 8) or
|
||
$0000f000 and (LongWord(B.Style) shl 12) or
|
||
$007f0000 and (LongWord(L.Color) shl 16) or
|
||
$3f800000 and (LongWord(R.Color) shl 23) or
|
||
$40000000 and (LongWord(LTRB) shl 30) or
|
||
$80000000 and (LongWord(LBRT) shl 31);
|
||
|
||
X.BStyle2 :=
|
||
$0000007f and LongWord(T.Color) or
|
||
$00003f80 and (LongWord(B.Color) shl 7) or
|
||
$001fc000 and (LongWord(D.Color) shl 14) or
|
||
$01e00000 and (LongWord(D.Style) shl 21) or
|
||
$fc000000 and (LongWord(Patt) shl 26);
|
||
|
||
X.Pattern :=
|
||
$007f and Word(PattColor) or
|
||
$3f80 and (Word(PattBgColor) shl 7);
|
||
end;
|
||
|
||
Stream.Add(BiffIdXF).Write(X, SizeOf(X));
|
||
end;
|
||
|
||
function TBiffXF.Equals(XF: TBiffObject): Boolean;
|
||
begin
|
||
Result := GetHashCode = XF.GetHashCode;
|
||
end;
|
||
|
||
function TBiffXF.GetHashCode: Integer;
|
||
begin
|
||
if Hash = 0 then
|
||
TCryptoHash.Hash('Jenkins', Hash, SizeOf(Hash), Data, SizeOf(Data));
|
||
|
||
Result := Hash;
|
||
end;
|
||
|
||
{ TBiffRow }
|
||
|
||
constructor TBiffRow.Create;
|
||
begin
|
||
Cells := TObjList.Create;
|
||
XF := 15;
|
||
end;
|
||
|
||
destructor TBiffRow.Destroy;
|
||
begin
|
||
Cells.Free;
|
||
end;
|
||
|
||
procedure TBiffRow.Flush(Stream: TBiffStream);
|
||
|
||
function GetHeight: Word;
|
||
begin
|
||
Result := $8000;
|
||
if Height > 0 then Result := Height and $7FFF;
|
||
end;
|
||
|
||
function GetFormat: LongWord;
|
||
var
|
||
f: LongWord;
|
||
begin
|
||
f :=
|
||
$00000007 and Outline or
|
||
$0FFF0000 and (XF shl 16);
|
||
|
||
SetBit(@f, 5, Hidden);
|
||
SetBit(@f, 6, Height > 0);
|
||
//SetBit(@f, 7, XF >= 0);
|
||
SetBit(@f, 8, True);
|
||
|
||
Result := f;
|
||
end;
|
||
|
||
var
|
||
Rec: TBiffrRow;
|
||
begin
|
||
ZeroMemory(@Rec, SizeOf(Rec));
|
||
|
||
Rec.Row := Row;
|
||
Rec.FirstCol := FirstCol;
|
||
Rec.LastCol := LastCol + 1;
|
||
Rec.Height := GetHeight;
|
||
Rec.Format := GetFormat;
|
||
|
||
Stream.Add(BiffIdRow).Write(Rec, SizeOf(Rec));
|
||
end;
|
||
|
||
{ TBiffWorkbook }
|
||
|
||
constructor TBiffWorkbook.Create;
|
||
var
|
||
i: LongInt;
|
||
x: TBiffXF;
|
||
sc: Integer;
|
||
begin
|
||
Sheets := TObjList.Create;
|
||
Fonts := TObjList.Create;
|
||
XFs := TObjList.Create;
|
||
SST := TObjList.Create;
|
||
Styles := TObjList.Create;
|
||
FFormats := TObjList.Create;
|
||
Win := TBiffWindow.Create;
|
||
Escher := TEscherStorage.Create;
|
||
|
||
{ Hashes }
|
||
|
||
XFHash := TListHashTable.Create;
|
||
SSTHash := TListHashTable.Create;
|
||
FontHash := TListHashTable.Create;
|
||
|
||
{ Critical section objects }
|
||
|
||
sc := 4000;
|
||
|
||
InitializeCriticalSectionAndSpinCount(FCsStrings, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsFonts, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsXFs, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsSheets, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsStyles, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsColors, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsPictures, sc);
|
||
InitializeCriticalSectionAndSpinCount(FCsFormats, sc);
|
||
|
||
{ 8 built-in colors }
|
||
|
||
PalUsed := 0;
|
||
|
||
AddColor($000000); // black
|
||
AddColor($FFFFFF); // white
|
||
AddColor($0000FF); // red
|
||
AddColor($00FF00); // green
|
||
AddColor($FF0000); // blue
|
||
AddColor($00FFFF); // yellow
|
||
AddColor($FF00FF); // magenta
|
||
AddColor($FFFF00); // cyan
|
||
|
||
{ 16 built-in XFs }
|
||
|
||
for i := 0 to 15 do
|
||
begin
|
||
x := TBiffXF.Create;
|
||
|
||
with x.Data do
|
||
begin
|
||
Prot := Prot or Byte(xftpStyle);
|
||
UsedAttrs := UsedAttrs or Byte(BiffXfuaFont);
|
||
end;
|
||
|
||
XFs.Add(x);
|
||
end;
|
||
|
||
with TBiffXF(XFs[0]).Data do
|
||
begin
|
||
UsedAttrs := $ff;
|
||
end;
|
||
|
||
with TBiffXF(XFs[15]).Data do
|
||
begin
|
||
Parent := 0;
|
||
Prot := Byte(xftpCellLocked);
|
||
UsedAttrs := 0;
|
||
end;
|
||
|
||
{ 1 built-in style for 0-th XF }
|
||
|
||
AddStyle(TBiffStyle.Create);
|
||
|
||
{ 4 built-in fonts }
|
||
|
||
Fonts.Add(TBiffFont.Create);
|
||
Fonts.Add(TBiffFont.Create);
|
||
Fonts.Add(TBiffFont.Create);
|
||
Fonts.Add(TBiffFont.Create);
|
||
end;
|
||
|
||
destructor TBiffWorkbook.Destroy;
|
||
begin
|
||
Sheets.Free;
|
||
Fonts.Free;
|
||
XFs.Free;
|
||
SST.Free;
|
||
Styles.Free;
|
||
Win.Free;
|
||
FFormats.Free;
|
||
Escher.Free;
|
||
FCipher.Free;
|
||
SSTHash.Free;
|
||
XFHash.Free;
|
||
FontHash.Free;
|
||
FLinkTbl.Free;
|
||
|
||
DeleteCriticalSection(FCsStrings);
|
||
DeleteCriticalSection(FCsFonts);
|
||
DeleteCriticalSection(FCsXFs);
|
||
DeleteCriticalSection(FCsSheets);
|
||
DeleteCriticalSection(FCsStyles);
|
||
DeleteCriticalSection(FCsColors);
|
||
DeleteCriticalSection(FCsPictures);
|
||
DeleteCriticalSection(FCsFormats);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockSst;
|
||
begin
|
||
EnterCriticalSection(FCsStrings);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockSst;
|
||
begin
|
||
LeaveCriticalSection(FCsStrings);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockSheets;
|
||
begin
|
||
EnterCriticalSection(FCsSheets);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockSheets;
|
||
begin
|
||
LeaveCriticalSection(FCsSheets);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockXfs;
|
||
begin
|
||
EnterCriticalSection(FCsXfs);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockXfs;
|
||
begin
|
||
LeaveCriticalSection(FCsXfs);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockColors;
|
||
begin
|
||
EnterCriticalSection(FCsColors);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockColors;
|
||
begin
|
||
LeaveCriticalSection(FCsColors);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockStyles;
|
||
begin
|
||
EnterCriticalSection(FCsStyles);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockStyles;
|
||
begin
|
||
LeaveCriticalSection(FCsStyles);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockPictures;
|
||
begin
|
||
EnterCriticalSection(FCsPictures);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockPictures;
|
||
begin
|
||
LeaveCriticalSection(FCsPictures);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockFonts;
|
||
begin
|
||
EnterCriticalSection(FCsFonts);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockFonts;
|
||
begin
|
||
LeaveCriticalSection(FCsFonts);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.LockFormats;
|
||
begin
|
||
EnterCriticalSection(FCsFormats);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.UnlockFormats;
|
||
begin
|
||
LeaveCriticalSection(FCsFormats);
|
||
end;
|
||
|
||
procedure TBiffWorkbook.SetPassword(const s: WideString);
|
||
begin
|
||
if s = '' then
|
||
begin
|
||
FCipher.Free;
|
||
FCipher := nil;
|
||
Exit;
|
||
end;
|
||
|
||
if FCipher = nil then
|
||
FCipher := TBiffRC4.Create;
|
||
|
||
with FCipher do
|
||
Prepare(s[1], 2 * Length(s));
|
||
end;
|
||
|
||
function TBiffWorkbook.AddSheet(S: TBiffSheet): LongWord;
|
||
begin
|
||
Assert(S <> nil);
|
||
LockSheets;
|
||
Result := Sheets.Add(S);
|
||
UnlockSheets;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddXF(X: TBiffXF): LongWord;
|
||
var
|
||
p: TBiffXF;
|
||
begin
|
||
LockXfs;
|
||
|
||
p := TBiffXF(XFHash.SetValue(X.GetHashCode, X));
|
||
|
||
{ The XF is new for this workbook }
|
||
|
||
if p = nil then
|
||
begin
|
||
Result := XFs.Add(X);
|
||
X.XfIndex := Result;
|
||
end
|
||
|
||
{ The XF already exists in the workbook }
|
||
|
||
else
|
||
begin
|
||
Result := p.XfIndex;
|
||
X.Free;
|
||
end;
|
||
|
||
UnlockXfs;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddFont(F: TBiffFont): LongWord;
|
||
var
|
||
p: TBiffFont;
|
||
begin
|
||
LockFonts;
|
||
|
||
p := TBiffFont(FontHash.SetValue(f.GetHashCode, Pointer(f)));
|
||
|
||
{ The font is already in the workbook }
|
||
|
||
if p = nil then
|
||
begin
|
||
Result := Fonts.Add(f);
|
||
f.FontIndex := Result;
|
||
end
|
||
else
|
||
|
||
{ The font is new for the workbook }
|
||
|
||
begin
|
||
Result := p.FontIndex;
|
||
f.Free;
|
||
end;
|
||
|
||
if Result > 3 then
|
||
Inc(Result);
|
||
|
||
UnlockFonts;
|
||
end;
|
||
|
||
procedure TBiffWorkbook.SetFormat(i: TBiffFormatIndex; const s: WideString);
|
||
begin
|
||
AddFormat(s, i);
|
||
end;
|
||
|
||
function TBiffWorkbook.AddFormat(const FormatStr: WideString;
|
||
FormatIndex: TBiffFormatIndex): TBiffFormatIndex;
|
||
var
|
||
i: LongInt;
|
||
s: TBiffUCS;
|
||
begin
|
||
if FormatStr = '' then
|
||
begin
|
||
|
||
{ This is the general format.
|
||
See the documentation for
|
||
the complete list of 164
|
||
predefined format values }
|
||
|
||
Result := 0;
|
||
Exit;
|
||
end;
|
||
|
||
LockFormats;
|
||
|
||
for i := 0 to FFormats.Count - 1 do
|
||
begin
|
||
s := TBiffUCS(FFormats[i]);
|
||
|
||
if (FormatIndex < 0) and (s.Tag = FormatIndex) then
|
||
begin
|
||
UnlockFormats;
|
||
raise Exception.CreateFmt('Format #%d already exists',
|
||
[FormatIndex]);
|
||
end;
|
||
|
||
if s.Data = FormatStr then
|
||
begin
|
||
UnlockFormats;
|
||
Result := s.Tag;
|
||
Exit;
|
||
end;
|
||
end;
|
||
|
||
s := TBiffUCS.Create(FormatStr, True);
|
||
s.Tag := FormatIndex;
|
||
LockFormats;
|
||
|
||
if s.Tag < 0 then
|
||
s.Tag := BiffUserFormat + FFormats.Count;
|
||
|
||
FFormats.Add(s);
|
||
UnlockFormats;
|
||
Result := s.Tag;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddBlip(Blip: TEscherPicture): LongInt;
|
||
begin
|
||
LockPictures;
|
||
|
||
with Escher.AddImage(Blip) do
|
||
begin
|
||
Inc(RefCount);
|
||
Result := Index;
|
||
end;
|
||
|
||
UnlockPictures;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddBitmap(Kind: TEscherBlipKind; Contents: TStream): LongInt;
|
||
var
|
||
p: TEscherBitmap;
|
||
begin
|
||
p := TEscherBitmap.Create;
|
||
p.Kind := Kind;
|
||
p.CopyFrom(Contents, 0);
|
||
Result := AddBlip(p);
|
||
end;
|
||
|
||
function TBiffWorkbook.AddMetafile(Metafile: Graphics.TMetafile): LongInt;
|
||
var
|
||
p: TEscherMetafile;
|
||
fx, fy: Extended;
|
||
begin
|
||
p := TEscherMetafile.Create;
|
||
p.Kind := EscherBkEMF;
|
||
p.Compr := False;
|
||
Metafile.Enhanced := True;
|
||
Metafile.SaveToStream(p);
|
||
|
||
with p.Bounds do
|
||
begin
|
||
Left := 0;
|
||
Top := 0;
|
||
Right := Metafile.Width;
|
||
Bottom := Metafile.Height;
|
||
end;
|
||
|
||
fx := 2.54 * 360000 / 96;
|
||
fy := 2.54 * 360000 / 96;
|
||
|
||
with p.MFSize do
|
||
begin
|
||
X := Round(Metafile.Width * fx);
|
||
Y := Round(Metafile.Height * fy);
|
||
end;
|
||
|
||
Result := AddBlip(p);
|
||
end;
|
||
|
||
function TBiffWorkbook.GetFontsCount: LongInt;
|
||
begin
|
||
Result := Fonts.Count;
|
||
end;
|
||
|
||
function TBiffWorkbook.GetLinkTable: TBiffLinkTable;
|
||
begin
|
||
if FLinkTbl = nil then
|
||
FLinkTbl := TBiffLinkTable.Create;
|
||
|
||
Result := FLinkTbl;
|
||
Assert(Result <> nil);
|
||
end;
|
||
|
||
function TBiffWorkbook.GetFont(Index: LongInt): TBiffFont;
|
||
begin
|
||
if (Index < 0) or (Index >= Fonts.Count) then
|
||
begin
|
||
Result := nil;
|
||
Exit;
|
||
end;
|
||
|
||
LockFonts;
|
||
Result := TBiffFont(Fonts[Index]);
|
||
UnlockFonts;
|
||
end;
|
||
|
||
function TBiffWorkbook.GetSheetsCount: LongInt;
|
||
begin
|
||
Result := Sheets.Count;
|
||
end;
|
||
|
||
function TBiffWorkbook.GetSheet(Index: LongInt): TBiffSheet;
|
||
begin
|
||
if (Index < 0) or (Index >= Sheets.Count) then
|
||
begin
|
||
Result := nil;
|
||
Exit;
|
||
end;
|
||
|
||
LockSheets;
|
||
Result := TBiffSheet(Sheets[Index]);
|
||
UnlockSheets;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddString(S: WideString): LongWord;
|
||
begin
|
||
Result := AddString(TBiffUCS.Create(S, True));
|
||
end;
|
||
|
||
function TBiffWorkbook.AddString(S: TBiffUCS): LongWord;
|
||
var
|
||
p: TBiffUCS;
|
||
begin
|
||
LockSst;
|
||
|
||
p := TBIffUCS(SSTHash.SetValue(S.GetHashCode, S));
|
||
|
||
{ If the string aleready exists }
|
||
|
||
if p <> nil then
|
||
begin
|
||
S.Free;
|
||
Result := p.SstIndex;
|
||
end
|
||
else
|
||
|
||
{ If the string is new for the workbook }
|
||
|
||
begin
|
||
Result := SST.Add(S);
|
||
S.SstIndex := Result;
|
||
end;
|
||
|
||
UnlockSst;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddStyle(S: TBiffStyle): LongInt;
|
||
begin
|
||
LockStyles;
|
||
Result := Styles.Add(S);
|
||
UnlockStyles;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddColor(C: LongWord): LongInt;
|
||
begin
|
||
LockColors;
|
||
Result := AddColorInternal(C);
|
||
UnlockColors;
|
||
end;
|
||
|
||
function TBiffWorkbook.AddColorInternal(C: LongWord): LongInt;
|
||
var
|
||
i: LongInt;
|
||
begin
|
||
C := ColorToRGB(Integer(C)) and $ffffff;
|
||
|
||
{ Find the nearest color.
|
||
|
||
Note that the new color is found starting from the Palette[7],
|
||
not from Palette[0], as may be expected. Excel don't like
|
||
colors with indexes 0..6, that's why these palette indexes are
|
||
ignored in this search. }
|
||
|
||
if PalUsed < 8 then
|
||
i := -1
|
||
else
|
||
i := 7 + NearestColor(@Palette[7], PalUsed - 7, C);
|
||
|
||
//
|
||
// If an exact match found, return the index.
|
||
//
|
||
|
||
if (i >= 0) and (Palette[i] = C) then
|
||
begin
|
||
Result := i;
|
||
Exit;
|
||
end;
|
||
|
||
//
|
||
// If no exact match found but palette is full,
|
||
// return an index to the nearest color.
|
||
//
|
||
|
||
if (i >= 0) and (PalUsed = BiffPaletteSize) then
|
||
begin
|
||
Result := i;
|
||
Exit;
|
||
end;
|
||
|
||
//
|
||
// If no exact match found and the palette is not full,
|
||
// add the new color.
|
||
//
|
||
|
||
Palette[PalUsed] := C;
|
||
Result := PalUsed;
|
||
Inc(PalUsed);
|
||
end;
|
||
|
||
function TBiffWorkbook.StringsCount: LongInt;
|
||
var
|
||
i: LongInt;
|
||
begin
|
||
LockSst;
|
||
Result := 0;
|
||
|
||
for i := 0 to Sheets.Count - 1 do
|
||
Inc(Result, TBiffSheet(Sheets[i]).TextCellsCount);
|
||
|
||
UnlockSst;
|
||
end;
|
||
|
||
procedure TBiffWorkbook.Flush(Stream: TBiffStream);
|
||
|
||
procedure WriteInt(RecId: TBiffRecId; Value, Size: LongInt);
|
||
begin
|
||
Stream.Add(RecId).Write(Value, Size);
|
||
end;
|
||
|
||
procedure WriteFonts;
|
||
begin
|
||
TBiffObject.FlushList(Fonts, Stream);
|
||
end;
|
||
|
||
procedure WriteXFs;
|
||
begin
|
||
TBiffObject.FlushList(XFs, Stream);
|
||
end;
|
||
|
||
procedure WriteSheets;
|
||
var
|
||
S: TBiffSheet;
|
||
R: TBiffrSheet;
|
||
UCS: TBiffUCS;
|
||
i: LongInt;
|
||
begin
|
||
for i := 0 to Sheets.Count - 1 do
|
||
begin
|
||
S := TBiffSheet(Sheets[i]);
|
||
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
R.Offset := 0; // Anything here. This will be overwritten. See docs.
|
||
R.Vis := Byte(S.Visibility);
|
||
R.Kind := Byte(S.Kind);
|
||
|
||
if i = 0 then
|
||
S.View.Options := S.View.Options or BiffWoSelected;
|
||
S.RecIndex := Stream.Count;
|
||
Stream.Add(BiffIdSheet).Write(R, SizeOf(R));
|
||
|
||
UCS := TBiffUCS.Create(S.Name, False);
|
||
UCS.Flush(Stream);
|
||
UCS.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure WriteSST;
|
||
var
|
||
R: TBiffrSST;
|
||
begin
|
||
if SST.Count = 0 then
|
||
Exit;
|
||
|
||
ZeroMemory(@R, SizeOf(R));
|
||
|
||
R.WBSCount := StringsCount;
|
||
R.SSTCount := SST.Count;
|
||
|
||
Stream.Add(BiffIdSST).Write(R, SizeOf(R));
|
||
TBiffObject.FlushList(SST, Stream);
|
||
end;
|
||
|
||
procedure WritePalette;
|
||
var
|
||
n: Integer;
|
||
begin
|
||
with Stream.Add(BiffIdPalette) do
|
||
begin
|
||
n := System.Length(Palette) - 8;
|
||
Assert(n = 56); // required by [MS-XLS] Section 2.4.188
|
||
|
||
WriteConst(n, 2);
|
||
Write(Palette[8], 4 * n);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteStyles;
|
||
begin
|
||
TBiffObject.FlushList(Styles, Stream);
|
||
end;
|
||
|
||
procedure WriteFormats;
|
||
var
|
||
ucs: TBiffUCS;
|
||
i: LongInt;
|
||
begin
|
||
for i := 0 to FFormats.Count - 1 do
|
||
begin
|
||
ucs := FFormats[i];
|
||
Stream.Add(BiffIdFormat).Write(ucs.Tag, 2);
|
||
ucs.Flush(Stream);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteEscher;
|
||
var
|
||
es: TEscherStream;
|
||
ms: TMemoryStream;
|
||
begin
|
||
if Escher.Empty then
|
||
Exit;
|
||
|
||
es := TEscherStream.Create;
|
||
ms := TMemoryStream.Create;
|
||
|
||
Escher.Flush(es);
|
||
es.Flush(ms);
|
||
|
||
Stream.Add(BiffIdEscher).Write(ms.Memory^, ms.Size);
|
||
|
||
ms.Free;
|
||
es.Free;
|
||
end;
|
||
|
||
procedure WriteFilePass;
|
||
begin
|
||
if FCipher <> nil then
|
||
FCipher.Flush(Stream);
|
||
end;
|
||
|
||
procedure WriteInterface;
|
||
begin
|
||
with Stream do
|
||
begin
|
||
Add(BiffIdInterfaceHdr).WriteConst(1200, 2);
|
||
Add(BiffIdMms).WriteConst(0, 2);
|
||
Add(BiffIdInterfaceEnd);
|
||
end;
|
||
end;
|
||
|
||
{ [MS-XLS] 2.4.349 }
|
||
|
||
procedure WriteAccess;
|
||
begin
|
||
with Stream.Add(BiffIdWriteAccess) do
|
||
begin
|
||
WriteConst($02, 2);
|
||
WriteConst($00, 2);
|
||
WriteCOnst($20, 1);
|
||
WriteConst($20, 1);
|
||
|
||
while Size < 112 do
|
||
WriteConst($20, 1);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteRRD;
|
||
var
|
||
i: LongInt;
|
||
begin
|
||
if SheetsCount > BiffRrdMaxCount then
|
||
Exit;
|
||
|
||
with Stream.Add(BiffIdRrd) do
|
||
for i := 0 to SheetsCount - 1 do
|
||
WriteConst(i + 1, 2);
|
||
end;
|
||
|
||
procedure WriteProt;
|
||
begin
|
||
with Stream do
|
||
begin
|
||
Add(BiffIdWinProt).WriteConst(0, 2);
|
||
Add(BiffIdProt).WriteConst(0, 2);
|
||
Add(BiffIdPassword).WriteConst(0, 2);
|
||
Add(BiffIdProtRev).WriteConst(0, 2);
|
||
Add(BiffIdProtRevPass).WriteConst(0, 2);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteExtSST;
|
||
begin
|
||
{ todo: EXTSST not emitted yet }
|
||
end;
|
||
|
||
procedure WriteLinkTable;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
if FLinkTbl = nil then
|
||
Exit;
|
||
|
||
FLinkTbl.SheetsCount := SheetsCount;
|
||
|
||
for i := 0 to Sheets.Count - 1 do
|
||
FLinkTbl.SetSheetIndex(TBiffSheet(Sheets[i]).Name, i);
|
||
|
||
FLinkTbl.Flush(Stream);
|
||
end;
|
||
|
||
var
|
||
i: LongInt;
|
||
begin
|
||
Stream.AddBOF(bkWBGlobals); // BOF
|
||
WriteFilePass; // FILEPASS
|
||
WriteInterface; // INTERFACEHDR MMS INTERFACEEND
|
||
WriteAccess; // WRITEACCESS
|
||
WriteInt(BiffIdCodepage, 1200, 2); // CODEPAGE
|
||
WriteInt(BiffIdDsf, 0, 2); // DSF
|
||
WriteRRD; // RRD
|
||
WriteProt; // WINPROTECT PROTECT PASSWORD PROTREV PROTREVPASS
|
||
Win.Flush(Stream); // WINDOW1
|
||
WriteInt(BiffIdBackup, 0, 2); // BACKUP
|
||
WriteInt(BiffIdHideObj, 0, 2); // HIDEOBJ
|
||
WriteInt(BiffIdDate1904, 0, 2); // DATE1904
|
||
WriteInt(BiffIdCalcPrec, 1, 2); // CALCPRECISION
|
||
WriteInt(BiffIdRefreshAll, 0, 2); // REFRESHALL
|
||
WriteInt(BiffIdBookBool, 0, 2); // BOOKBOOL
|
||
WriteFonts; // 1*510 FONT
|
||
WriteFormats; // 8*218 FORMAT
|
||
WriteXFs; // 16* XF
|
||
WriteStyles; // 1* STYLE
|
||
WritePalette; // PALETTE
|
||
WriteInt(BiffIdUserElf, 0, 2); // USERELF
|
||
WriteSheets; // SHEET
|
||
WriteInt(BiffIdCountry, $70007, 4); // COUNTRY
|
||
WriteEscher; // *ESCHER
|
||
WriteSST; // SST
|
||
WriteExtSST; // EXTSST
|
||
WriteLinkTable; // EXTRENALBOOK, EXTERNALSHEET, etc.
|
||
Stream.AddEOF; // EOF
|
||
|
||
{ Write sheets }
|
||
|
||
for i := 0 to Sheets.Count - 1 do
|
||
with TBiffSheet(Sheets[i]) do
|
||
begin
|
||
Stream[RecIndex].WriteBytes(0, Stream.Size, 4);
|
||
Flush(Stream);
|
||
end;
|
||
|
||
{ Encrypt the workbook if it needs }
|
||
|
||
if FCipher <> nil then
|
||
FCipher.EncryptStream(Stream);
|
||
end;
|
||
|
||
{ TBiffSheet }
|
||
|
||
constructor TBiffSheet.Create(Owner: TBiffWorkbook);
|
||
begin
|
||
FOwner := Owner;
|
||
|
||
FRows := TObjList.Create;
|
||
FCols := TObjList.Create;
|
||
|
||
FMrgCells := TObjectList.Create(True);
|
||
|
||
PageSetup := TBiffPageSetup.Create;
|
||
View := TBiffWindow2.Create;
|
||
|
||
Bounds.FR := -1;
|
||
Bounds.LR := -1;
|
||
Bounds.FC := -1;
|
||
Bounds.LC := -1;
|
||
|
||
FStrCount := 0;
|
||
Name := 'Sheet';
|
||
FKind := skWorksheet;
|
||
FVis := svVisible;
|
||
FPB := TList.Create;
|
||
end;
|
||
|
||
destructor TBiffSheet.Destroy;
|
||
begin
|
||
FRows.Free;
|
||
FCols.Free;
|
||
FMrgCells.Free;
|
||
PageSetup.Free;
|
||
View.Free;
|
||
FPB.Free;
|
||
end;
|
||
|
||
procedure TBiffSheet.SetColWidth(i: LongInt; w: LongInt);
|
||
begin
|
||
if (i >= 0) and (i <= BiffMaxCol) then
|
||
AddColInfo(TBiffColInfo.Create(i, 15, w));
|
||
end;
|
||
|
||
procedure TBiffSheet.SetRowHeight(i: LongInt; h: LongInt);
|
||
var
|
||
r: TBiffRow;
|
||
c: TBiffCell;
|
||
begin
|
||
if (i < 0) or (i > BiffMaxRow) then
|
||
Exit;
|
||
|
||
r := GetRow(i);
|
||
|
||
if r = nil then
|
||
begin
|
||
c := TBiffCell.Create;
|
||
with c do
|
||
begin
|
||
Row := i;
|
||
Col := 0;
|
||
end;
|
||
|
||
AddCell(c);
|
||
r := GetRow(i);
|
||
end;
|
||
|
||
if r <> nil then
|
||
r.Height := h;
|
||
end;
|
||
|
||
function TBiffSheet.GetColWidth(i: LongInt): LongInt;
|
||
var
|
||
j: LongInt;
|
||
begin
|
||
for j := FCols.Count - 1 downto 0 do
|
||
with TBiffColInfo(FCols[j]) do
|
||
if (First <= i) and (i <= Last) then
|
||
begin
|
||
Result := Width;
|
||
Exit;
|
||
end;
|
||
|
||
Result := 0;
|
||
end;
|
||
|
||
function TBiffSheet.GetRowHeight(i: LongInt): LongInt;
|
||
var
|
||
r: TBiffRow;
|
||
begin
|
||
r := GetRow(i);
|
||
if r = nil then
|
||
Result := 0
|
||
else
|
||
Result := r.Height;
|
||
end;
|
||
|
||
function TBiffSheet.LastRowIndex: LongInt;
|
||
begin
|
||
Result := Bounds.LR;
|
||
end;
|
||
|
||
procedure TBiffSheet.MergeCells(Rect: TRect);
|
||
var
|
||
_Rectangle: TRectangle;
|
||
begin
|
||
Assert((Rect.Left <= Rect.Right) and (Rect.Top <= Rect.Bottom));
|
||
|
||
{ There's no need to merge a 1x1 rectangle of cells }
|
||
|
||
if (Rect.Left = Rect.Right) and (Rect.Top = Rect.Bottom) then
|
||
Exit;
|
||
|
||
{ todo: Rect should be checked for intersections with all existing
|
||
merged blocks, but it'd be slow or it'd require a complex algorithm }
|
||
|
||
_Rectangle := TRectangle.Create;
|
||
_Rectangle.TopLeft := Rect.TopLeft;
|
||
_Rectangle.BottomRight := Rect.BottomRight;
|
||
FMrgCells.Add(_Rectangle);
|
||
end;
|
||
|
||
procedure TBiffSheet.AddPageBreak(Row: LongInt);
|
||
begin
|
||
FPB.Add(Pointer(Row));
|
||
end;
|
||
|
||
function TBiffSheet.AddDrawing: TEscherShape;
|
||
begin
|
||
if FDGroup = nil then
|
||
FDGroup := FOwner.Escher.AddGroup;
|
||
|
||
Result := FDGRoup.Add;
|
||
end;
|
||
|
||
procedure TBiffSheet.AddColInfo(Info: TBiffColInfo);
|
||
begin
|
||
FCols.Add(Info);
|
||
end;
|
||
|
||
function TBiffSheet.GetRow(Index: LongInt): TBiffRow;
|
||
var
|
||
i, r: Longint;
|
||
begin
|
||
{ In most cases, only one iteration of this loop is executed,
|
||
because this function is optimised for sequential access. }
|
||
|
||
for i := 0 to FRows.Count - 1 do
|
||
begin
|
||
r := (FLastReadRow + i) mod FRows.Count;
|
||
|
||
if TBiffRow(FRows[r]).Row = Index then
|
||
begin
|
||
Result := TBiffRow(FRows[r]);
|
||
FLastReadRow := r + 1;
|
||
Exit;
|
||
end;
|
||
end;
|
||
|
||
Result := nil;
|
||
end;
|
||
|
||
//
|
||
// There is a list of rows, where each row contains
|
||
// a list of cells. The rows in the list are ordered
|
||
// by the row index by ascending. This function
|
||
// looks for a place in the list of rows and adds to there
|
||
// a cell with the specified coordinates.
|
||
//
|
||
|
||
procedure TBiffSheet.AddCell(Cell: TBiffCell);
|
||
|
||
function CreateRow(Cell: TBiffCell): TBiffRow;
|
||
var
|
||
R: TBiffRow;
|
||
begin
|
||
R := TBiffRow.Create;
|
||
R.Row := Cell.Row;
|
||
R.Cells.Add(Cell);
|
||
|
||
R.FirstCol := Cell.Col;
|
||
R.LastCol := Cell.Col;
|
||
|
||
Result := R;
|
||
end;
|
||
|
||
procedure AttachToRow(R: TBiffRow; Cell: TBiffCell);
|
||
begin
|
||
R.Cells.Add(Cell);
|
||
|
||
if Cell.Col < R.FirstCol then
|
||
R.FirstCol := Cell.Col;
|
||
|
||
if Cell.Col > R.LastCol then
|
||
R.LastCol := Cell.Col;
|
||
end;
|
||
|
||
procedure InsertRow(Cell: TBiffCell);
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FRows.Count - 1;
|
||
|
||
while (i >= 0) and (TBiffRow(FRows[i]).Row > Cell.Row) do
|
||
Dec(i);
|
||
|
||
if (i >= 0) and (TBiffRow(FRows[i]).Row = Cell.Row) then
|
||
AttachToRow(TBiffRow(FRows[i]), Cell)
|
||
else
|
||
FRows.Insert(i + 1, CreateRow(Cell));
|
||
end;
|
||
|
||
procedure AdjustBounds(r, c: LongInt; var b: TBiffBounds);
|
||
begin
|
||
with b do
|
||
begin
|
||
if (r < FR) or (FR < 0) then
|
||
FR := r;
|
||
|
||
if (r > LR) or (LR < 0) then
|
||
LR := r;
|
||
|
||
if (c < FC) or (FC < 0) then
|
||
FC := c;
|
||
|
||
if (c > LC) or (LC < 0) then
|
||
LC := c;
|
||
end;
|
||
end;
|
||
|
||
begin
|
||
InsertRow(Cell);
|
||
AdjustBounds(Cell.Row, Cell.Col, Bounds);
|
||
|
||
if Cell is TBiffTextCell then
|
||
Inc(FStrCount);
|
||
end;
|
||
|
||
procedure TBiffSheet.Flush(Stream: TBiffStream);
|
||
|
||
procedure WriteInt(RecId: TBiffRecId; Value, Size: LongInt);
|
||
begin
|
||
Stream.Add(RecId).Write(Value, Size);
|
||
end;
|
||
|
||
procedure WriteF8(RecId: TBiffRecId; Value: Double);
|
||
begin
|
||
Stream.Add(RecId).Write(Value, 8);
|
||
end;
|
||
|
||
procedure WriteDIMENSION;
|
||
var
|
||
Dim: TBiffrDimension;
|
||
begin
|
||
ZeroMemory(@Dim, SizeOf(Dim));
|
||
|
||
with Bounds do
|
||
begin
|
||
{ If FR or FC values are negative, then
|
||
this sheet contains no cells }
|
||
|
||
if FR < 0 then
|
||
FR := 0;
|
||
|
||
if FC < 0 then
|
||
FC := 0;
|
||
|
||
Dim.FirstRow := Bounds.FR;
|
||
Dim.LastRow := Bounds.LR + 1;
|
||
Dim.FirstCol := Bounds.FC;
|
||
Dim.LastCol := Bounds.LC + 1;
|
||
end;
|
||
|
||
Stream.Add(BiffIdDim).Write(Dim, Sizeof(Dim));
|
||
end;
|
||
|
||
//
|
||
// todo
|
||
//
|
||
|
||
procedure WriteCells(R: TBiffRow);
|
||
begin
|
||
TBiffObject.FlushList(R.Cells, Stream);
|
||
end;
|
||
|
||
procedure WriteCOLINFO;
|
||
begin
|
||
TBiffObject.FlushList(FCols, Stream);
|
||
end;
|
||
|
||
//
|
||
// BIFF8 requires that a MERGEDCELLS record
|
||
// is not continued by a CONTINUE record, so
|
||
// merged blocks will be grouped by 1024 items
|
||
// and written in different MERGEDCELLS records.
|
||
//
|
||
|
||
procedure WriteMergedCells;
|
||
|
||
procedure WriteBlock(First, Last: Integer);
|
||
var
|
||
m: TBiffrCellsBlock;
|
||
i: Integer;
|
||
begin
|
||
with Stream.Add(BiffIdMergedCells) do
|
||
begin
|
||
WriteConst(Last - First + 1, 2);
|
||
|
||
for i := First to Last do
|
||
begin
|
||
with m, TRectangle(FMrgCells[i]) do
|
||
begin
|
||
FR := Top;
|
||
LR := Bottom;
|
||
FC := Left;
|
||
LC := Right;
|
||
end;
|
||
|
||
Write(m, SizeOf(m));
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
var
|
||
i, n: Integer;
|
||
begin
|
||
n := Min(BiffMaxMrgCellsNum, (BiffMaxRecLen - 2) div 8);
|
||
i := 0;
|
||
|
||
while i < FMrgCells.Count do
|
||
begin
|
||
WriteBlock(i, Min(i + n - 1, FMrgCells.Count - 1));
|
||
Inc(i, n);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteMargins;
|
||
|
||
procedure WM(Id: LongInt; Value: Double);
|
||
begin
|
||
Stream.Add(Id).Write(Value, 8);
|
||
end;
|
||
|
||
begin
|
||
with Margin do
|
||
begin
|
||
WM(BiffIdLeftMargin, Left);
|
||
WM(BiffIdTopMargin, Top);
|
||
WM(BiffIdRightMargin, Right);
|
||
WM(BiffIdBottomMargin, Bottom);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteDrawings;
|
||
var
|
||
es: TEscherStream;
|
||
ms: TMemoryStream;
|
||
|
||
begin
|
||
if FDGroup = nil then
|
||
Exit;
|
||
|
||
es := TEscherStream.Create;
|
||
ms := TMemoryStream.Create;
|
||
|
||
FDGroup.Flush(es);
|
||
es.Flush(ms);
|
||
|
||
Stream.Add(BiffIdDrawing).Write(ms.Memory^, ms.Size);
|
||
|
||
ms.Free;
|
||
es.Free;
|
||
end;
|
||
|
||
procedure WriteGOBJ;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
if FDGroup = nil then
|
||
Exit;
|
||
|
||
// [MS-XLS] 2.4.181
|
||
|
||
for i := 0 to FDGroup.Count - 1 do
|
||
with Stream.Add(BiffIdGObj) do
|
||
begin
|
||
// [MS-XLS] 2.5.143
|
||
|
||
WriteConst($15, 2); // record id
|
||
WriteConst($12, 2); // record len
|
||
WriteConst($08, 2);
|
||
WriteZeros(16);
|
||
|
||
// [MS-XLS] 2.5.142
|
||
|
||
WriteConst($07, 2); // record id
|
||
WriteConst($02, 2); // record len
|
||
WriteConst($ffff, 2);
|
||
|
||
// [MS-XLS} 2.5.151
|
||
|
||
WriteConst($08, 2); // record id
|
||
WriteConst($02, 2); // record len
|
||
WriteConst($00, 2);
|
||
end;
|
||
end;
|
||
|
||
procedure WritePageBreak;
|
||
var
|
||
i: LongInt;
|
||
begin
|
||
if FPB.Count = 0 then Exit;
|
||
with Stream.Add(BiffIdHorPageBreak) do
|
||
begin
|
||
Write(FPB.Count, 2);
|
||
|
||
for i := 0 to FPB.Count - 1 do
|
||
begin
|
||
WriteConst(LongInt(FPB[i]), 2);
|
||
WriteConst(0, 2);
|
||
WriteConst(BiffMaxCol, 2);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure WriteIndex;
|
||
begin
|
||
{ todo: INDEX not emitted yet }
|
||
end;
|
||
|
||
procedure WriteGuts;
|
||
begin
|
||
with Stream.Add(BiffIdGuts) do
|
||
begin
|
||
WriteConst(0, 4);
|
||
WriteConst(0, 4);
|
||
end;
|
||
end;
|
||
|
||
{ Actual format of DEFROWHEIGHT see
|
||
in [MS-XLS] section 2.4.87 }
|
||
|
||
procedure WriteDefRowHeight;
|
||
begin
|
||
with Stream.Add(BiffIdDefRowHeight) do
|
||
begin
|
||
WriteConst(0, 2);
|
||
WriteConst(300, 2);
|
||
end;
|
||
end;
|
||
|
||
procedure WriteWsBool;
|
||
begin
|
||
WriteInt(
|
||
BiffIdWsBool,
|
||
|
||
//BiffWsbFitPage or
|
||
BiffWsbShowBreaks or
|
||
BiffWsbRowSums or
|
||
BiffWsbColSums,
|
||
|
||
2);
|
||
end;
|
||
|
||
var
|
||
i, j, fi, li, mi: LongInt;
|
||
r, fr: TBiffRow;
|
||
|
||
begin
|
||
Stream.AddBOF(bkSheet); // BOF
|
||
WriteIndex; // INDEX
|
||
WriteInt(BiffIdCalcMode, 1, 2); // CALCMODE
|
||
WriteInt(BiffIdCalcCount, 100, 2); // CALCCOUNT
|
||
WriteInt(BiffIdCalcRefMode, 1, 2); // CALCREFMODE
|
||
WriteInt(BiffIdCalcIter, 0, 2); // CALCITER
|
||
WriteF8(BiffIdCalcDelta, 0.001); // CALCDELTA
|
||
WriteInt(BiffIdSaveRecalc, 1, 2); // SAVERECALC
|
||
WriteInt(BiffIdPrintRowCol, 0, 2); // PRINTROWCOL
|
||
WriteInt(BiffIdPrintGrid, 0, 2); // PRINTGRID
|
||
WriteInt(BiffIdGridSet, 1, 2); // GRIDSET
|
||
WriteGuts; // GUTS
|
||
WriteDefRowHeight; // DEFROWHEIGHT
|
||
WriteWsBool; // WSBOOL
|
||
WritePageBreak; // HPAGEBREAK
|
||
Stream.Add(BiffIdHeader); // HEADER
|
||
Stream.Add(BiffIdFooter); // FOOTER
|
||
WriteInt(BiffIdHCenter, 0, 2); // HCENTER
|
||
WriteInt(BiffIdVCenter, 0, 2); // VCENTER
|
||
WriteMargins; // LEFTMARGIN TOPMARGIN RIGHTMARGIN BOTTOMMARGIN
|
||
PageSetup.Flush(Stream); // PAGESETUP
|
||
WriteInt(BiffIdDefColWidth, 8, 2); // DEFCOLWIDTH
|
||
WriteCOLINFO; // COLINFO
|
||
WriteDIMENSION; // DIMENSION
|
||
|
||
fi := 0;
|
||
|
||
if FRows.Count > 0 then
|
||
repeat
|
||
//
|
||
// MS Excel allows up to 32 rows written
|
||
// consequently. Each block of 32 rows must be ended
|
||
// with a DBCELL record.
|
||
//
|
||
|
||
fr := TBiffRow(FRows[fi]);
|
||
mi := fr.Row + BiffRowBlockSz - 1;
|
||
|
||
//
|
||
// Write ROW records
|
||
//
|
||
|
||
i := fi;
|
||
|
||
repeat
|
||
r := TBiffRow(FRows[i]);
|
||
if r.Row > mi then
|
||
Break;
|
||
|
||
r.Offset := Stream.Size;
|
||
r.Flush(Stream);
|
||
Inc(i);
|
||
until i = FRows.Count;
|
||
|
||
li := i - 1;
|
||
|
||
//
|
||
// Write cells
|
||
//
|
||
|
||
for i := fi to li do
|
||
begin
|
||
r := TBiffRow(FRows[i]);
|
||
if r.Cells.Count = 0 then
|
||
Continue;
|
||
|
||
r.FirstCell := Stream.Size;
|
||
TBiffObject(r.Cells[0]).Flush(Stream);
|
||
|
||
for j := 1 to r.Cells.Count - 1 do
|
||
TBiffObject(r.Cells[j]).Flush(Stream);
|
||
end;
|
||
|
||
//
|
||
// Write DBCELL
|
||
//
|
||
|
||
with Stream.Add(BiffIdDBCell) do
|
||
begin
|
||
WriteConst(Offset - fr.Offset, 4);
|
||
for i := fi to li do
|
||
begin
|
||
r := TBiffRow(FRows[i]);
|
||
WriteConst(r.FirstCell - r.Offset - 4 - SizeOf(TBiffrRow), 2);
|
||
end;
|
||
end;
|
||
|
||
fi := li + 1;
|
||
until fi = FRows.Count;
|
||
|
||
WriteDrawings; // DRAWING
|
||
//WriteGOBJ; // GOBJ
|
||
View.Flush(Stream); // WINDOW2
|
||
WriteMergedCells; // MERGEDCELLS
|
||
|
||
Stream.AddEOF; // EOF
|
||
end;
|
||
|
||
{ TBiffUCS }
|
||
|
||
constructor TBiffUCS.Create;
|
||
begin
|
||
Init;
|
||
end;
|
||
|
||
constructor TBiffUCS.Create(const S: WideString; UCS16: Boolean);
|
||
begin
|
||
Init;
|
||
Data := S;
|
||
Len16 := UCS16;
|
||
end;
|
||
|
||
destructor TBiffUCS.Destroy;
|
||
begin
|
||
FRuns.Free;
|
||
end;
|
||
|
||
procedure TBiffUCS.Init;
|
||
begin
|
||
FRuns := TMemoryStream.Create;
|
||
FCompress := True;
|
||
end;
|
||
|
||
procedure TBiffUCS.AddFormat(Position, Font: LongInt);
|
||
begin
|
||
FRuns.Write(Position, 2);
|
||
FRuns.Write(Font, 2);
|
||
end;
|
||
|
||
function TBiffUCS.IsCompressible: Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
if not FCompress then
|
||
begin
|
||
Result := False;
|
||
Exit;
|
||
end;
|
||
|
||
for i := 1 to Length(Data) do
|
||
if Word(Ord(Data[i])) > 255 then
|
||
begin
|
||
Result := False;
|
||
Exit;
|
||
end;
|
||
|
||
Result := True;
|
||
end;
|
||
|
||
procedure TBiffUCS.Flush(Stream: TBiffStream);
|
||
|
||
procedure WriteStr(s: PWideChar; len: LongWord; flags: Byte);
|
||
var
|
||
n: LongWord;
|
||
buffer: array[0..BiffMaxRecLen - 2] of AnsiChar;
|
||
|
||
//
|
||
// Prepares up to "count" bytes from the string
|
||
// to be written to a record
|
||
//
|
||
|
||
procedure Prepare(count: LongWord);
|
||
label
|
||
copychar;
|
||
var
|
||
x, i: LongWord;
|
||
begin
|
||
if (flags and 1) = 1 then
|
||
begin
|
||
x := count shr 1;
|
||
if x > len then
|
||
x := len;
|
||
|
||
n := x*2;
|
||
CopyMemory(@buffer[0], s, n);
|
||
|
||
s := PWideChar(LongWord(s) + n);
|
||
Dec(len, x);
|
||
Exit;
|
||
end;
|
||
|
||
n := count;
|
||
|
||
if n > len then
|
||
n := len;
|
||
|
||
for i := 0 to n - 1 do
|
||
buffer[i] := PAnsiChar(LongWord(s) + 2*i)^;
|
||
|
||
Dec(len, n);
|
||
s := PWideChar(LongWord(s) + 2*n);
|
||
end;
|
||
|
||
begin
|
||
n := BiffMaxRecLen - Stream[Stream.Count - 1].Size;
|
||
|
||
if n > 0 then
|
||
begin
|
||
Prepare(n);
|
||
Stream[Stream.Count - 1].Write(buffer[0], n);
|
||
end;
|
||
|
||
while len > 0 do
|
||
begin
|
||
Prepare(BiffMaxRecLen - 1);
|
||
with Stream.Add(BiffIdContinue) do
|
||
begin
|
||
Write(flags, 1);
|
||
Write(buffer[0], n);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
var
|
||
hSize: LongWord; // header size with the first character
|
||
f: Byte; // flags
|
||
r: TBiffRecord; // first available record
|
||
compr: Boolean; // set if the string is compressible
|
||
frn: LongWord; // count of formatting runs
|
||
lDataSize: Cardinal;
|
||
begin
|
||
compr := IsCompressible;
|
||
frn := FRuns.Size shr 2;
|
||
|
||
//
|
||
// Calculate the size of the header.
|
||
//
|
||
|
||
hSize := 2;
|
||
|
||
if Len16 then
|
||
Inc(hSize);
|
||
|
||
if frn > 0 then
|
||
Inc(hSize, 2);
|
||
|
||
if Data <> '' then
|
||
if compr then
|
||
Inc(hSize, 1)
|
||
else
|
||
Inc(hSize, 2);
|
||
|
||
f := 0;
|
||
|
||
if not compr then
|
||
f := 1; // compression flag
|
||
|
||
if frn > 0 then
|
||
f := f or 8; // formatting runs flag
|
||
|
||
//
|
||
// Find the first available record
|
||
// that capable to keep the header
|
||
// and write the header.
|
||
//
|
||
lDataSize := Length(Data);
|
||
// keep with runs as well #486459
|
||
r := Stream[Stream.Count - 1];
|
||
if (r = nil) or (r.Size + hSize > BiffMaxRecLen) or
|
||
(r.Size + hSize + lDataSize * 2 + FRuns.Size + 1 > BiffMaxRecLen) then
|
||
r := Stream.Add(BiffIdContinue);
|
||
|
||
if Len16 then
|
||
r.WriteConst(lDataSize, 2)
|
||
else
|
||
r.WriteConst(lDataSize, 1);
|
||
|
||
r.Write(f, 1);
|
||
if frn > 0 then
|
||
r.Write(frn, 2);
|
||
|
||
if Data <> '' then
|
||
begin
|
||
if compr then
|
||
r.Write(Data[1], 1)
|
||
else
|
||
r.Write(Data[1], 2);
|
||
|
||
//
|
||
// Write characters
|
||
// and formatting runs.
|
||
//
|
||
|
||
if lDataSize > 1 then
|
||
WriteStr(@Data[2], lDataSize - 1, f and 1);
|
||
|
||
if frn > 0 then
|
||
Stream[Stream.Count - 1].Write(FRuns.Memory^, FRuns.Size);
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffUCS.SetData(const Value: WideString);
|
||
begin
|
||
FData := Value;
|
||
FHash := 0;
|
||
end;
|
||
|
||
function TBiffUCS.Equals(s: TBiffObject): Boolean;
|
||
begin
|
||
if s.GetHashCode = GetHashCode then
|
||
Result := TBiffUCS(s).Data = Data
|
||
else
|
||
Result := False;
|
||
end;
|
||
|
||
function TBiffUCS.GetHashCode: LongInt;
|
||
begin
|
||
if FHash <> 0 then
|
||
begin
|
||
Result := FHash;
|
||
Exit;
|
||
end;
|
||
|
||
if FData <> '' then
|
||
TCryptoHash.Hash('Jenkins', FHash, SizeOf(FHash),
|
||
FData[1], Length(FData) * SizeOf(FData[1]))
|
||
else
|
||
FHash := 0;
|
||
|
||
Result := FHash;
|
||
end;
|
||
|
||
{ TBiffRecord }
|
||
|
||
constructor TBiffRecord.Create(Owner: TBiffStream; Offset: Cardinal);
|
||
begin
|
||
FOwner := Owner;
|
||
FOffset := Offset;
|
||
end;
|
||
|
||
function TBiffRecord.GetRecId: TBiffRecId;
|
||
begin
|
||
Result := TBiffRecId(FOwner.ReadBytes(Offset, 2))
|
||
end;
|
||
|
||
function TBiffRecord.GetSize: Cardinal;
|
||
begin
|
||
Result := FOwner.ReadBytes(Offset + 2, 2)
|
||
end;
|
||
|
||
procedure TBiffRecord.SetSize(n: Cardinal);
|
||
begin
|
||
Assert(n <= BiffMaxRecLen);
|
||
FOwner.WriteBytes(Offset + 2, n, 2);
|
||
end;
|
||
|
||
procedure TBiffRecord.Write(const Buffer; Count: Cardinal);
|
||
begin
|
||
if Count > 0 then
|
||
FOwner.AppendRecord(Self, Buffer, Count);
|
||
end;
|
||
|
||
procedure TBiffRecord.WriteConst(Value, Size: Cardinal);
|
||
begin
|
||
Assert((Size > 0) and (Size <= SizeOf(Value)));
|
||
Write(Value, Size);
|
||
end;
|
||
|
||
procedure TBiffRecord.WriteStream(Stream: TStream);
|
||
var
|
||
Buffer: array[0..63] of Byte;
|
||
n: Integer;
|
||
begin
|
||
Stream.Position := 0;
|
||
|
||
repeat
|
||
n := Stream.Read(Buffer[0], SizeOf(Buffer));
|
||
|
||
if n > 0 then
|
||
Write(Buffer[0], n);
|
||
until n = 0;
|
||
end;
|
||
|
||
procedure TBiffRecord.WriteZeros(Size: Cardinal);
|
||
begin
|
||
Assert(Size > 0);
|
||
|
||
while Size > SizeOf(Integer) do
|
||
begin
|
||
WriteConst(0, SizeOf(Integer));
|
||
Dec(Size, SizeOf(Integer));
|
||
end;
|
||
|
||
if Size > 0 then
|
||
WriteConst(0, Size);
|
||
end;
|
||
|
||
procedure TBiffRecord.WriteBytes(Offset, Data, Count: Cardinal);
|
||
begin
|
||
Assert(Count in [1..SizeOf(Data)]);
|
||
Assert(Offset + Count <= Size);
|
||
|
||
FOwner.FStream.Position := FOffset + 4 + Offset;
|
||
FOwner.FStream.WriteBuffer(Data, Count);
|
||
end;
|
||
|
||
procedure TBiffRecord.LoadFromStream(Stream: TStream);
|
||
begin
|
||
if Size > 0 then
|
||
begin
|
||
FOwner.FStream.Position := Offset + 4;
|
||
FOwner.FStream.CopyFrom(Stream, Size);
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffRecord.SaveToStream(Stream: TStream);
|
||
begin
|
||
if Size > 0 then
|
||
begin
|
||
FOwner.FStream.Position := Offset + 4;
|
||
Stream.CopyFrom(FOwner.FStream, Size);
|
||
end;
|
||
end;
|
||
|
||
procedure SerialiseBiffRecord(Stream: TStream; Rec: TObject);
|
||
begin
|
||
with Rec as TBiffRecord do
|
||
begin
|
||
Stream.WriteBuffer(FOwner, SizeOf(FOwner));
|
||
Stream.WriteBuffer(FOffset, SizeOf(FOffset));
|
||
end;
|
||
end;
|
||
|
||
function DeserialiseBiffRecord(Stream: TStream): TObject;
|
||
var
|
||
FOwner: TBiffStream;
|
||
FOffset: Cardinal;
|
||
begin
|
||
with Stream do
|
||
begin
|
||
ReadBuffer(FOwner, SizeOf(FOwner));
|
||
ReadBuffer(FOffset, SizeOf(FOffset));
|
||
end;
|
||
|
||
Result := TBiffRecord.Create(FOwner, FOffset);
|
||
end;
|
||
|
||
{ TBiffStream }
|
||
|
||
constructor TBiffStream.Create(Cached: Boolean);
|
||
begin
|
||
if Cached then
|
||
begin
|
||
FStream := TFileStream.Create(GetTempFile, fmCreate);
|
||
FRecords := TListCache.Create(GetTempFile, GetTempFile);
|
||
FRecords.WriteObj := SerialiseBiffRecord;
|
||
FRecords.ReadObj := DeserialiseBiffRecord;
|
||
end
|
||
else
|
||
begin
|
||
FStream := TMemoryStream.Create;
|
||
FRecords := TListCache.Create;
|
||
end;
|
||
end;
|
||
|
||
destructor TBiffStream.Destroy;
|
||
begin
|
||
FStream.Free;
|
||
FRecords.Free;
|
||
end;
|
||
|
||
function TBiffStream.GetRecCount: Integer;
|
||
begin
|
||
Result := FRecords.Count
|
||
end;
|
||
|
||
function TBiffStream.GetRecord(Index: LongInt): TBiffRecord;
|
||
begin
|
||
Result := TBiffRecord(FRecords[Index])
|
||
end;
|
||
|
||
function TBiffStream.GetSize: Cardinal;
|
||
begin
|
||
Result := FStream.Size
|
||
end;
|
||
|
||
procedure TBiffStream.SaveToStream(Stream: TStream);
|
||
begin
|
||
Stream.CopyFrom(FStream, 0)
|
||
end;
|
||
|
||
function TBiffStream.ReadBytes(Offset, Count: Cardinal): Cardinal;
|
||
begin
|
||
Assert((Count in [1..SizeOf(Result)]) and (Offset + Count <= Size));
|
||
Result := 0;
|
||
FStream.Position := Offset;
|
||
FStream.ReadBuffer(Result, Count);
|
||
end;
|
||
|
||
procedure TBiffStream.WriteBytes(Offset, Data, Count: Cardinal);
|
||
begin
|
||
Assert((Count in [1..SizeOf(Data)]) and (Offset + Count <= Size));
|
||
FStream.Position := Offset;
|
||
FStream.WriteBuffer(Data, Count);
|
||
end;
|
||
|
||
function TBiffStream.Add(Id: TBiffRecId): TBiffRecord;
|
||
begin
|
||
Result := TBiffRecord.Create(Self, Size);
|
||
FRecords.Add(Result);
|
||
|
||
if Id <> BiffIdContinue then
|
||
FLastRec := Result;
|
||
|
||
Append(Id, 2); // record id
|
||
Append(0, 2); // record size (will be updated)
|
||
end;
|
||
|
||
function TBiffStream.AddBOF(K: TBiffStreamKind): TBiffRecord;
|
||
var
|
||
r: TBiffrBOF;
|
||
begin
|
||
ZeroMemory(@r, SizeOf(r));
|
||
|
||
r.Version := $600;
|
||
r.Year := 1997;
|
||
r.Kind := K;
|
||
r.Build := 8211;
|
||
r.Flags1 := BiffBoffWin or (3 shl 14);
|
||
r.Flags1 := r.Flags1 or BiffBoffWinAny;
|
||
r.Flags2 := 6 or (3 shl 8);
|
||
|
||
Result := Add(BiffIdBOF);
|
||
Result.Write(r, SizeOf(r));
|
||
end;
|
||
|
||
function TBiffStream.AddEOF: TBiffRecord;
|
||
begin
|
||
Result := Add(BiffIdEOF)
|
||
end;
|
||
|
||
procedure TBiffStream.AppendData(const Data; Count: Cardinal);
|
||
begin
|
||
Assert(@Data <> nil);
|
||
Assert(Count > 0);
|
||
FStream.Seek(0, soFromEnd);
|
||
FStream.WriteBuffer(Data, Count);
|
||
end;
|
||
|
||
procedure TBiffStream.Append(Data, Count: Cardinal);
|
||
begin
|
||
Assert(Count in [1..SizeOf(Data)]);
|
||
AppendData(Data, Count)
|
||
end;
|
||
|
||
procedure TBiffStream.AppendRecord(Rec: TBiffRecord; const Data; DataSize: Cardinal);
|
||
|
||
procedure MoveData(var Src: Pointer; var Size: Cardinal; Count: Cardinal);
|
||
begin
|
||
Assert(Count <= Size);
|
||
|
||
if Count > 0 then
|
||
begin
|
||
AppendData(Src^, Count);
|
||
Dec(Size, Count);
|
||
Src := Pointer(frxCardinal(Src) + Count);
|
||
end;
|
||
end;
|
||
|
||
var
|
||
n: Cardinal;
|
||
DataPtr: Pointer;
|
||
begin
|
||
Assert(Count > 0);
|
||
Assert(@Data <> nil);
|
||
Assert((Rec = FLastRec) or (Rec = Records[Count - 1]), 'Only the last record can be modified');
|
||
|
||
DataPtr := @Data;
|
||
n := Min(DataSize, BiffMaxRecLen - Records[Count - 1].Size);
|
||
MoveData(DataPtr, DataSize, n);
|
||
|
||
with Records[Count - 1] do
|
||
Size := Size + n;
|
||
|
||
{ The data chunk is too big: CONTINUE records are needed.
|
||
[MS-XLS] 2.4.58 }
|
||
|
||
while DataSize > 0 do
|
||
begin
|
||
FRecords.Add(TBiffRecord.Create(Self, Size));
|
||
n := Min(BiffMaxRecLen, DataSize);
|
||
|
||
Append(BiffIdContinue, 2);
|
||
Append(n, 2);
|
||
MoveData(DataPtr, DataSize, n);
|
||
end;
|
||
end;
|
||
|
||
{ TBiffLinkTable }
|
||
|
||
function TBiffLinkTable.GetInternalSheetRef(const SheetName: string): Integer;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FindSheet(SheetName);
|
||
|
||
if i = RefsCount then
|
||
begin
|
||
RefsCount := RefsCount + 1;
|
||
FIntSheetNames[RefsCount - 1] := SheetName;
|
||
end;
|
||
|
||
Result := i;
|
||
Assert(FIntSheetNames[i] = SheetName);
|
||
end;
|
||
|
||
function TBiffLinkTable.GetRefsCount: Integer;
|
||
begin
|
||
Result := Length(FIntSheetNames)
|
||
end;
|
||
|
||
procedure TBiffLinkTable.SetRefsCount(n: Integer);
|
||
begin
|
||
SetLength(FIntSheetNames, n);
|
||
SetLength(FIntSheetIndex, n);
|
||
end;
|
||
|
||
procedure TBiffLinkTable.SetSheetIndex(const SheetName: string; Index: Integer);
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FindSheet(SheetName);
|
||
|
||
if i < RefsCount then
|
||
FIntSheetIndex[i] := Index;
|
||
end;
|
||
|
||
function TBiffLinkTable.FindSheet(const Name: string): Integer;
|
||
begin
|
||
for Result := 0 to RefsCount - 1 do
|
||
if FIntSheetNames[Result] = Name then
|
||
Exit;
|
||
|
||
Result := RefsCount;
|
||
end;
|
||
|
||
procedure TBiffLinkTable.Flush(Stream: TBiffStream);
|
||
var
|
||
i: Integer;
|
||
begin
|
||
with Stream.Add(BiffIdExtBook) do
|
||
begin
|
||
WriteConst(SheetsCount, 2);
|
||
WriteConst(1, 1);
|
||
WriteConst(4, 1);
|
||
end;
|
||
|
||
with Stream.Add(BiffIdExtSheet) do
|
||
begin
|
||
WriteConst(RefsCount, 2);
|
||
|
||
for i := 0 to RefsCount - 1 do
|
||
begin
|
||
WriteConst(0, 2); // index to EXTBOOK
|
||
WriteConst(FIntSheetIndex[i], 2); // index to first sheet
|
||
WriteConst(FIntSheetIndex[i], 2); // index to last sheet
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
{ TBiffFormulaCell }
|
||
|
||
constructor TBiffFormulaCell.Create(Instructions: TStream);
|
||
begin
|
||
FInst := Instructions;
|
||
end;
|
||
|
||
destructor TBiffFormulaCell.Destroy;
|
||
begin
|
||
FInst.Free;
|
||
inherited;
|
||
end;
|
||
|
||
procedure TBiffFormulaCell.Flush(Stream: TBiffStream);
|
||
var
|
||
f: TBiffrFormula;
|
||
begin
|
||
ZeroMemory(@f, SizeOf(f));
|
||
|
||
with f do
|
||
begin
|
||
Cell.Row := Row;
|
||
Cell.Column := Col;
|
||
Cell.XF := XF;
|
||
|
||
Value := 0;
|
||
InstLen := FInst.Size;
|
||
end;
|
||
|
||
with Stream.Add(BiffIdFormula) do
|
||
begin
|
||
Write(f, Sizeof(f));
|
||
WriteStream(FInst);
|
||
end;
|
||
end;
|
||
|
||
{ TBiffFormulaCodeEmitter }
|
||
|
||
procedure TBiffFormulaCodeEmitter.Error(const ErrorMsg: string);
|
||
begin
|
||
raise EBiffFormulaCodeEmitterError.Create(ErrorMsg)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Ensure(b: Boolean; const ErrorMsg: string);
|
||
begin
|
||
if not b then
|
||
Error(ErrorMsg)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.EnsureCellRange(const Cell: TBiffFormulaCellRef);
|
||
begin
|
||
Ensure((Cell.Row >= 0) and (Cell.Row < $10000), 'Row index is out of bounds');
|
||
Ensure((Cell.Col >= 0) and (Cell.Col < $100), 'Column index is out of bounds');
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Write(Inst, Len: Cardinal);
|
||
begin
|
||
Assert((Len > 0) and (Len <= SizeOf(Inst)));
|
||
Assert(FInst <> nil);
|
||
FInst.WriteBuffer(Inst, Len);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.WriteAreaRef(const Cell1, Cell2: TBiffFormulaCellRef);
|
||
begin
|
||
EnsureCellRange(Cell1);
|
||
EnsureCellRange(Cell2);
|
||
|
||
Write(Cell1.Row, 2);
|
||
Write(Cell2.Row, 2);
|
||
Write(Cell1.Col, 1);
|
||
Write(RelFlags(not Cell1.AbsRow, not Cell1.AbsCol));
|
||
Write(Cell2.Col, 1);
|
||
Write(RelFlags(not Cell2.AbsRow, not Cell2.AbsCol));
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.WriteCellRef(const Cell: TBiffFormulaCellRef);
|
||
begin
|
||
EnsureCellRange(Cell);
|
||
|
||
Write(Cell.Row, 2);
|
||
Write(Cell.Col, 1);
|
||
Write(RelFlags(not Cell.AbsRow, not Cell.AbsCol));
|
||
end;
|
||
|
||
function TBiffFormulaCodeEmitter.RelFlags(RelRow, RelCol: Boolean): Byte;
|
||
begin
|
||
Result := 0;
|
||
|
||
if RelCol then
|
||
Result := Result or $40;
|
||
|
||
if RelRow then
|
||
Result := Result or $80;
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.WriteOpCode(Op: Byte);
|
||
begin
|
||
Assert(Op and $e0 = 0);
|
||
|
||
case RetMode of
|
||
frtRef: Op := Op or $20;
|
||
frtVal: Op := Op or $40;
|
||
frtArray: Op := Op or $60;
|
||
|
||
else Error('Invalid RetType mode');
|
||
end;
|
||
|
||
Write(Op, 1)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Range;
|
||
begin
|
||
Write($11)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Intersect;
|
||
begin
|
||
Write($0f)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Join;
|
||
begin
|
||
Write($08)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CallId;
|
||
begin
|
||
Write($15)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CmpE;
|
||
begin
|
||
Write($0b)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CmpG;
|
||
begin
|
||
Write($0d)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CmpGE;
|
||
begin
|
||
Write($0c)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CmpL;
|
||
begin
|
||
Write($09)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CmpLE;
|
||
begin
|
||
Write($0a)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.CmpNE;
|
||
begin
|
||
Write($0e)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Div100;
|
||
begin
|
||
Write($14)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Divide;
|
||
begin
|
||
Write($06)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Mul;
|
||
begin
|
||
Write($05)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Neg;
|
||
begin
|
||
Write($13)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Add;
|
||
begin
|
||
Write($03)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Sub;
|
||
begin
|
||
Write($04)
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Pow;
|
||
begin
|
||
Write($07);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Push(Value: Integer);
|
||
begin
|
||
Ensure((Value >= 0) and (Value < $10000));
|
||
Write($1e);
|
||
Write(Value, 2);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Push(Value: Double);
|
||
begin
|
||
Write($1f);
|
||
FInst.WriteBuffer(Value, 8);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.PushNull;
|
||
begin
|
||
Write($16);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Push(const s: string);
|
||
begin
|
||
Ensure(Length(s) < $100, 'String is too long');
|
||
|
||
Write($17);
|
||
Write(Length(s));
|
||
|
||
if SizeOf(s[1]) = 1 then
|
||
Write(0)
|
||
else
|
||
Write(1);
|
||
|
||
if s <> '' then
|
||
FInst.WriteBuffer(s[1], Length(s) * SizeOf(s[1]));
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Push(b: Boolean);
|
||
begin
|
||
Write($1d);
|
||
|
||
if b then
|
||
Write(1)
|
||
else
|
||
Write(0);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Call(Func: Cardinal);
|
||
begin
|
||
Ensure(Func < $10000);
|
||
|
||
WriteOpCode($01);
|
||
Write(Func, 2);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.Call(Func, NumArgs: Cardinal);
|
||
begin
|
||
Ensure(Func < $8000);
|
||
Ensure(NumArgs < $80);
|
||
|
||
WriteOpCode($02);
|
||
Write(NumArgs and $7f);
|
||
Write(Func and $7fff, 2);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.PushArea(const Cell1, Cell2: TBiffFormulaCellRef);
|
||
begin
|
||
WriteOpCode($05);
|
||
WriteAreaRef(Cell1, Cell2);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.PushCell(const Cell: TBiffFormulaCellRef);
|
||
begin
|
||
WriteOpCode($04);
|
||
WriteCellRef(Cell);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.PushExtArea(SheetRefId: Integer; const Cell1, Cell2: TBiffFormulaCellRef);
|
||
begin
|
||
Ensure((SheetRefId >= 0) and (SheetRefId < $10000));
|
||
|
||
WriteOpCode($1b);
|
||
Write(SheetRefId, 2);
|
||
WriteAreaRef(Cell1, Cell2);
|
||
end;
|
||
|
||
procedure TBiffFormulaCodeEmitter.PushExtCell(SheetRefId: Integer; const Cell: TBiffFormulaCellRef);
|
||
begin
|
||
Ensure((SheetRefId >= 0) and (SheetRefId < $10000));
|
||
|
||
WriteOpCode($1a);
|
||
Write(SheetRefId, 2);
|
||
WriteCellRef(Cell);
|
||
end;
|
||
|
||
{ TBiffFormulaLexer }
|
||
|
||
procedure TBiffFormulaLexer.Add(const Lex: TBiffFormulaLexem);
|
||
begin
|
||
SetLength(FLexems, Length(FLexems) + 1);
|
||
FLexems[High(FLexems)] := Lex;
|
||
end;
|
||
|
||
procedure TBiffFormulaLexer.Add(LexKind: TBiffFormulaLexemKind; const LexText: string);
|
||
var
|
||
Lex: TBiffFormulaLexem;
|
||
begin
|
||
Lex.Kind := LexKind;
|
||
Lex.Text := LexText;
|
||
Add(Lex);
|
||
end;
|
||
|
||
function TBiffFormulaLexer.GetLexemsCount: Integer;
|
||
begin
|
||
Result := Length(FLexems)
|
||
end;
|
||
|
||
function TBiffFormulaLexer.IsAlpha(c: Char): Boolean;
|
||
begin
|
||
Result := AnsiChar(c) in ['a'..'z', 'A'..'Z']
|
||
end;
|
||
|
||
function TBiffFormulaLexer.IsDigit(c: Char): Boolean;
|
||
begin
|
||
Result := AnsiChar(c) in ['0'..'9']
|
||
end;
|
||
|
||
function TBiffFormulaLexer.NextChar: Char;
|
||
begin
|
||
Assert(FPos <= Length(FText));
|
||
Result := FText[FPos + 1];
|
||
end;
|
||
|
||
function TBiffFormulaLexer.Read(Len: Integer): string;
|
||
begin
|
||
Assert(FPos + Len <= Length(FText) + 1);
|
||
Result := Copy(FText, FPos, Len);
|
||
Inc(FPos, Len);
|
||
end;
|
||
|
||
procedure TBiffFormulaLexer.SkipChar;
|
||
begin
|
||
Assert(FPos <= Length(FText));
|
||
Inc(FPos);
|
||
end;
|
||
|
||
function TBiffFormulaLexer.SubStr(Pos, Len: Integer): string;
|
||
begin
|
||
Assert(Pos + Len <= Length(FText) + 1);
|
||
Result := Copy(FText, Pos, Len);
|
||
end;
|
||
|
||
function TBiffFormulaLexer.GetChar: Char;
|
||
begin
|
||
Assert((FPos >= 0) and (FPos <= Length(FText) + 1));
|
||
|
||
if FPos = Length(FText) + 1 then
|
||
Result := #0
|
||
else
|
||
Result := FText[FPos];
|
||
end;
|
||
|
||
function TBiffFormulaLexer.GetLexem(i: Integer): TBiffFormulaLexem;
|
||
begin
|
||
Assert((i >= 0) and (i < Count));
|
||
Result := FLexems[i];
|
||
end;
|
||
|
||
procedure TBiffFormulaLexer.Analyse(const Formula: string);
|
||
begin
|
||
SetLength(FLexems, 0);
|
||
FText := Formula;
|
||
FPos := 1;
|
||
|
||
while FPos <= Length(FText) do
|
||
if not AddSpace then
|
||
if not AddNumber then
|
||
if not AddName then
|
||
if not AddString('"') then
|
||
if not AddString('''') then
|
||
if not AddOp then
|
||
if not AddSymbol then
|
||
Inc(FPos);
|
||
|
||
Assert(FPos = Length(FText) + 1);
|
||
end;
|
||
|
||
function TBiffFormulaLexer.AddName: Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FPos;
|
||
|
||
if IsAlpha(GetChar) then
|
||
while IsAlpha(GetChar) do
|
||
SkipChar;
|
||
|
||
Result := i < FPos;
|
||
|
||
if Result then
|
||
Add(flkName, SubStr(i, FPos - i));
|
||
end;
|
||
|
||
function TBiffFormulaLexer.AddNumber: Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FPos;
|
||
|
||
if IsDigit(GetChar) then
|
||
while IsDigit(GetChar) do
|
||
SkipChar;
|
||
|
||
Result := i < FPos;
|
||
|
||
if Result then
|
||
Add(flkInt, SubStr(i, FPos - i));
|
||
end;
|
||
|
||
function TBiffFormulaLexer.AddOp: Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FPos;
|
||
|
||
case GetChar of
|
||
'+', '-', '*', '/', '%', '^', '&', ':', '!', '=':
|
||
Add(flkOp, Read(1));
|
||
'<':
|
||
if AnsiChar(NextChar) in ['>', '='] then
|
||
Add(flkOp, Read(2))
|
||
else
|
||
Add(flkOp, Read(1));
|
||
'>':
|
||
if NextChar = '=' then
|
||
Add(flkOp, Read(2))
|
||
else
|
||
Add(flkOp, Read(1));
|
||
end;
|
||
|
||
Result := i < FPos;
|
||
end;
|
||
|
||
function TBiffFormulaLexer.AddSpace: Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FPos;
|
||
|
||
while AnsiChar(GetChar) in [#1..#32] do
|
||
SkipChar;
|
||
|
||
Result := i < FPos;
|
||
|
||
if Result then
|
||
Add(flkSpace, '');
|
||
end;
|
||
|
||
function TBiffFormulaLexer.AddString(Quote: Char): Boolean;
|
||
|
||
function Clean(const s: string): string;
|
||
begin
|
||
Result := StringReplace(s, '""', '"', [rfReplaceAll])
|
||
end;
|
||
|
||
var
|
||
i: Integer;
|
||
begin
|
||
i := FPos;
|
||
|
||
if GetChar = Quote then
|
||
begin
|
||
SkipChar;
|
||
|
||
while GetChar <> #0 do
|
||
if GetChar <> Quote then
|
||
SkipChar
|
||
else if NextChar <> Quote then
|
||
Break
|
||
else
|
||
begin
|
||
SkipChar;
|
||
SkipChar;
|
||
end;
|
||
|
||
if GetChar = Quote then
|
||
SkipChar
|
||
else
|
||
FPos := i;
|
||
end;
|
||
|
||
Result := i < FPos;
|
||
|
||
if Result then
|
||
Add(flkString, Clean(SubStr(i + 1, FPos - i - 2)))
|
||
end;
|
||
|
||
function TBiffFormulaLexer.AddSymbol: Boolean;
|
||
begin
|
||
Add(flkSymbol, Read(1));
|
||
Result := True;
|
||
end;
|
||
|
||
{ TBiffFormulaRPNStack }
|
||
|
||
function TBiffFormulaRPNStack.Top(const a: TBiffFormulaTokenArray): TBiffFormulaToken;
|
||
begin
|
||
Assert(Length(a) > 0);
|
||
Result := a[High(a)];
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.Pop(var a: TBiffFormulaTokenArray): TBiffFormulaToken;
|
||
begin
|
||
Result := Top(a);
|
||
SetLength(a, Length(a) - 1);
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.Push(var Res: TBiffFormulaTokenArray; const t: TBiffFormulaToken);
|
||
begin
|
||
SetLength(Res, Length(Res) + 1);
|
||
Res[High(Res)] := t;
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.PushFrame(const Func: string);
|
||
var
|
||
t: TBiffFormulaToken;
|
||
begin
|
||
t.Kind := ftkOp;
|
||
t.Op := fokFunc;
|
||
t.Text := Func;
|
||
t.Flags := Length(FStack) shl 8 or Byte(FNumArgs);
|
||
|
||
Push(FFrame, t);
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.PopFrame;
|
||
var
|
||
Func: TBiffFormulaToken;
|
||
begin
|
||
Unroll;
|
||
Func := Top(FFrame);
|
||
|
||
if Func.Text = '' then
|
||
Pop(FFrame) // Func is the identity function
|
||
else
|
||
begin
|
||
Func.Flags := GetFrameArgs;
|
||
Dec(FNumArgs, GetFrameArgs - 1);
|
||
Pop(FFrame);
|
||
Push(FCode, Func);
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.PushOp(Op: TBiffFormulaOperatorKind; const Text: string; NumArgs: Integer);
|
||
var
|
||
t: TBiffFormulaToken;
|
||
begin
|
||
t.Kind := ftkOp;
|
||
t.Op := Op;
|
||
t.Text := Text;
|
||
t.Flags := NumArgs;
|
||
|
||
PushOp(t);
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.PushOp(Op: TBiffFormulaToken);
|
||
begin
|
||
if Joinable(Op.Op) then
|
||
Push(FStack, Op)
|
||
else
|
||
begin
|
||
PopOp;
|
||
PushOp(Op); // recusrion
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.PopOp;
|
||
var
|
||
Op: TBiffFormulaToken;
|
||
begin
|
||
Op := Pop(FStack);
|
||
Push(FCode, Op);
|
||
Dec(FNumArgs, Op.Flags - 1);
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.PushArg(Op: TBiffFormulaOperatorKind; const Text: string; Flags: Integer);
|
||
var
|
||
t: TBiffFormulaToken;
|
||
begin
|
||
t.Kind := ftkArg;
|
||
t.Op := Op;
|
||
t.Text := Text;
|
||
t.Flags := Flags;
|
||
|
||
Push(FCode, t);
|
||
Inc(FNumArgs);
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.Ensure(b: Boolean; const Msg: string);
|
||
begin
|
||
if not b then
|
||
Error(Msg)
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.Error(const Msg: string);
|
||
begin
|
||
raise EBiffFormulaRPNStackError.Create(Msg)
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.GetFrameArgs: Integer;
|
||
begin
|
||
if Length(FFrame) = 0 then
|
||
Result := FNumArgs
|
||
else
|
||
Result := FNumArgs - (Top(FFrame).Flags and $ff);
|
||
|
||
Assert(Result >= 0);
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.GetFrameOps: Integer;
|
||
begin
|
||
if Length(FFrame) = 0 then
|
||
Result := Length(FStack)
|
||
else
|
||
Result := Length(FStack) - (Top(FFrame).Flags shr 8);
|
||
|
||
Assert(Result >= 0);
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.OpPriority(Kind: TBiffFormulaOperatorKind): Integer;
|
||
begin
|
||
case Kind of
|
||
fokPush:
|
||
Result := 8;
|
||
|
||
fokColon, fokArea:
|
||
Result := 7;
|
||
|
||
fokExt:
|
||
Result := 6;
|
||
|
||
fokNeg, fokDiv100:
|
||
Result := 5;
|
||
|
||
fokPow:
|
||
Result := 4;
|
||
|
||
fokDiv, fokMul, fokIsect:
|
||
Result := 3;
|
||
|
||
fokAdd, fokSub:
|
||
Result := 2;
|
||
|
||
fokL, fokG, fokE, fokNE, fokLE, fokGE:
|
||
Result := 1;
|
||
|
||
else
|
||
Result := 0; // unrecognized operators have the lowest priority
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.GetCount: Integer;
|
||
begin
|
||
Result := Length(FCode)
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.GetInstruction(i: Integer): TBiffFormulaToken;
|
||
begin
|
||
Assert((i >= 0) and (i < Count));
|
||
Result := FCode[i];
|
||
end;
|
||
|
||
procedure TBiffFormulaRPNStack.Unroll;
|
||
var
|
||
Op: TBiffFormulaToken;
|
||
begin
|
||
while GetFrameOps > 0 do
|
||
begin
|
||
Op := Pop(FStack);
|
||
Ensure(GetFrameArgs >= Op.Flags);
|
||
Push(FCode, Op);
|
||
Dec(FNumArgs, Op.Flags - 1);
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaRPNStack.Joinable(Op: TBiffFormulaOperatorKind): Boolean;
|
||
var
|
||
a, b: TBiffFormulaOperatorKind;
|
||
begin
|
||
if GetFrameOps = 0 then
|
||
Result := True // this is the first op in the current frame
|
||
else
|
||
begin
|
||
a := Top(FStack).Op;
|
||
b := Op;
|
||
|
||
{ Given an expression (X a Y b Z) where a and b are operators,
|
||
this function must return True if (Y b Z) must be calculated first;
|
||
and return False if (X a Y) must be calculated first. }
|
||
|
||
if OpPriority(a) < OpPriority(b) then
|
||
Result := True
|
||
|
||
else if OpPriority(a) > OpPriority(b) then
|
||
Result := False
|
||
|
||
else if (a = fokPow) and (b = fokPow) then
|
||
Result := True
|
||
|
||
else
|
||
Result := False;
|
||
end;
|
||
end;
|
||
|
||
{ TBiffFormulaParser }
|
||
|
||
procedure TBiffFormulaParser.BuildLexems(const s: string);
|
||
var
|
||
Lex: TBiffFormulaLexer;
|
||
i: Integer;
|
||
begin
|
||
Lex := TBiffFormulaLexer.Create;
|
||
|
||
try
|
||
Lex.Formula := s;
|
||
SetLength(FLexems, Lex.Count);
|
||
|
||
for i := 0 to Lex.Count - 1 do
|
||
FLexems[i] := Lex[i];
|
||
finally
|
||
Lex.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.CleanLexems;
|
||
var
|
||
n: Integer;
|
||
|
||
procedure Move(i: Integer);
|
||
begin
|
||
Assert(i >= n);
|
||
|
||
if i > n then
|
||
FLexems[n] := FLexems[i];
|
||
|
||
Inc(n);
|
||
end;
|
||
|
||
function Lex(i: Integer): TBiffFormulaLexem;
|
||
begin
|
||
if (i < 0) or (i > High(FLexems)) then
|
||
Result.Kind := flkVoid
|
||
else
|
||
Result := FLexems[i]
|
||
end;
|
||
|
||
function CanIgnoreSpace(i: Integer): Boolean;
|
||
var
|
||
a, b: TBiffFormulaLexem;
|
||
begin
|
||
a := Lex(i - 1);
|
||
b := Lex(i + 1);
|
||
|
||
Result :=
|
||
(a.Kind = flkVoid) or (b.Kind = flkVoid) or
|
||
(a.Kind = flkOp) or (b.Kind = flkOp) or
|
||
(a.Text = '(') or (b.Text = ')') or
|
||
IsArgSep(a) or IsArgSep(b)
|
||
end;
|
||
|
||
var
|
||
i: Integer;
|
||
begin
|
||
n := 0;
|
||
|
||
for i := 0 to High(FLexems) do
|
||
with FLexems[i] do
|
||
case Kind of
|
||
flkSpace:
|
||
if not CanIgnoreSpace(i) then
|
||
Move(i);
|
||
|
||
else
|
||
Move(i);
|
||
end;
|
||
|
||
SetLength(FLexems, n);
|
||
end;
|
||
|
||
function TBiffFormulaParser.IsArgSep(const Lex: TBiffFormulaLexem): Boolean;
|
||
begin
|
||
Result := (Lex.Kind = flkSymbol) and ((Lex.Text = ',') or (Lex.Text = ';'))
|
||
end;
|
||
|
||
function TBiffFormulaParser.IsOp(const Lex: TBiffFormulaLexem; const Text: string): Boolean;
|
||
begin
|
||
Result := (Lex.Kind = flkOp) and (Lex.Text = Text)
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Ensure(b: Boolean; const ErrorMsg: string);
|
||
begin
|
||
if not b then
|
||
Error(ErrorMsg)
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Error(const ErrorMsg: string);
|
||
begin
|
||
raise EBiffFormulaParserError.Create(ErrorMsg)
|
||
end;
|
||
|
||
function TBiffFormulaParser.GetToken(i: Integer): TBiffFormulaToken;
|
||
begin
|
||
Assert((i >= 0) and (i < Length(FCode)));
|
||
Result := FCode[i];
|
||
end;
|
||
|
||
function TBiffFormulaParser.GetTokensCount: Integer;
|
||
begin
|
||
Result := Length(FCode)
|
||
end;
|
||
|
||
function TBiffFormulaParser.CreateArgToken(Kind: TBiffFormulaOperatorKind;
|
||
const Text: string; Flags: Integer): TBiffFormulaToken;
|
||
begin
|
||
Result.Kind := ftkArg;
|
||
Result.Op := Kind;
|
||
Result.Text := Text;
|
||
Result.Flags := Flags;
|
||
end;
|
||
|
||
function TBiffFormulaParser.Lexem(i: Integer): TBiffFormulaLexem;
|
||
|
||
function GetLexKind(i: Integer): TBiffFormulaLexemKind;
|
||
begin
|
||
if (i >= 0) and (i < Length(FLexems)) then
|
||
Result := FLexems[i].Kind
|
||
else
|
||
Result := flkVoid
|
||
end;
|
||
|
||
begin
|
||
case GetLexKind(FPos + i) of
|
||
flkVoid:
|
||
Result.Kind := flkVoid;
|
||
|
||
flkSpace:
|
||
begin
|
||
Result.Kind := flkOp;
|
||
Result.Text := ' ';
|
||
end;
|
||
|
||
else
|
||
Result := FLexems[FPos + i];
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.SkipLexem;
|
||
begin
|
||
Assert(FPos < Length(FLexems));
|
||
Inc(FPos);
|
||
end;
|
||
|
||
function TBiffFormulaParser.SkipLexemIf(Kind: TBiffFormulaLexemKind; out Text: string): Boolean;
|
||
begin
|
||
Result := Lexem.Kind = Kind;
|
||
|
||
if Result then
|
||
begin
|
||
Text := Lexem.Text;
|
||
SkipLexem;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaParser.SkipLexemIf(const Text: string): Boolean;
|
||
begin
|
||
Result := Lexem.Text = Text;
|
||
|
||
if Result then
|
||
SkipLexem;
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Save;
|
||
begin
|
||
SetLength(FSavedPos, Length(FSavedPos) + 1);
|
||
FSavedPos[High(FSavedPos)] := FPos;
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Load;
|
||
begin
|
||
Assert(Length(FSavedPos) > 0);
|
||
FPos := FSavedPos[High(FSavedPos)];
|
||
SetLength(FSavedPos, Length(FSavedPos) - 1);
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Discard;
|
||
begin
|
||
Assert(Length(FSavedPos) > 0);
|
||
SetLength(FSavedPos, Length(FSavedPos) - 1);
|
||
end;
|
||
|
||
function TBiffFormulaParser.OpKind(const s: string): TBiffFormulaOperatorKind;
|
||
begin
|
||
Assert(s <> '');
|
||
Result := fokVoid;
|
||
|
||
case Length(s) of
|
||
1:
|
||
case s[1] of
|
||
'+': Result := fokAdd;
|
||
'-': Result := fokSub;
|
||
'*': Result := fokMul;
|
||
'/': Result := fokDiv;
|
||
'^': Result := fokPow;
|
||
'<': Result := fokL;
|
||
'>': Result := fokG;
|
||
'=': Result := fokE;
|
||
':': Result := fokColon;
|
||
' ': Result := fokIsect;
|
||
'!': Result := fokExt;
|
||
'&': Result := fokJoin;
|
||
end;
|
||
|
||
2:
|
||
if s = '<=' then
|
||
Result := fokLE
|
||
|
||
else if s = '>=' then
|
||
Result := fokGE
|
||
|
||
else if s = '<>' then
|
||
Result := fokNE;
|
||
end;
|
||
|
||
Ensure(Result <> fokVoid, Format('Operator "%s" is unknown', [s]));
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Push(Arg: TBiffFormulaOperatorKind; const Text: string; Flags: Integer);
|
||
begin
|
||
FRPN.PushArg(Arg, Text, Flags);
|
||
FRPN.PushOp(fokPush, 'push', 1);
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.CopyCodeFromRPNStack;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
SetLength(FCode, FRPN.Count);
|
||
|
||
for i := 0 to FRPN.Count - 1 do
|
||
FCode[i] := FRPN[i];
|
||
end;
|
||
|
||
procedure TBiffFormulaParser.Parse(const s: string);
|
||
begin
|
||
BuildLexems(s);
|
||
CleanLexems;
|
||
FPos := 0;
|
||
|
||
try
|
||
FRPN := TBiffFormulaRPNStack.Create;
|
||
Ensure(ParseFormula);
|
||
CopyCodeFromRPNStack;
|
||
finally
|
||
FRPN.Free;
|
||
FRPN := nil;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadCell(out t: TBiffFormulaToken): Boolean;
|
||
var
|
||
AbsCol, AbsRow: Boolean;
|
||
ColName, RowName: string;
|
||
Flags: Integer;
|
||
begin
|
||
Result := False;
|
||
Save;
|
||
|
||
AbsCol := SkipLexemIf('$');
|
||
|
||
if not SkipLexemIf(flkName, ColName) then
|
||
begin
|
||
Load;
|
||
Exit;
|
||
end;
|
||
|
||
AbsRow := SkipLexemIf('$');
|
||
|
||
if not SkipLexemIf(flkInt, RowName) then
|
||
begin
|
||
Load;
|
||
Exit;
|
||
end;
|
||
|
||
Flags := 0;
|
||
|
||
if AbsRow then
|
||
Flags := Flags or 1;
|
||
|
||
if AbsCol then
|
||
Flags := Flags or 2;
|
||
|
||
Discard;
|
||
t := CreateArgToken(fokCell, ColName + RowName, Flags);
|
||
Result := True;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadName(out s: string): Boolean;
|
||
var
|
||
Name: string;
|
||
begin
|
||
if Lexem.Kind <> flkName then
|
||
Result := False
|
||
else
|
||
begin
|
||
Name := Lexem.Text;
|
||
SkipLexem;
|
||
|
||
if Lexem.Kind = flkInt then
|
||
begin
|
||
Name := Name + Lexem.Text;
|
||
SkipLexem;
|
||
end;
|
||
|
||
s := Name;
|
||
Result := True;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadNumber(out s: string): Boolean;
|
||
var
|
||
Num: string;
|
||
begin
|
||
if Lexem.Kind <> flkInt then
|
||
Result := False
|
||
else
|
||
begin
|
||
Num := Lexem.Text;
|
||
SkipLexem;
|
||
|
||
if Lexem.Text = '.' then
|
||
begin
|
||
Num := Num + '.';
|
||
SkipLexem;
|
||
|
||
if Lexem.Kind = flkInt then
|
||
begin
|
||
Num := Num + Lexem.Text;
|
||
SkipLexem;
|
||
end
|
||
else
|
||
Num := Num + '0';
|
||
end;
|
||
|
||
s := Num;
|
||
Result := True;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadOp(out s: string): Boolean;
|
||
begin
|
||
Result := Lexem.Kind = flkOp;
|
||
|
||
if Result then
|
||
begin
|
||
s := Lexem.Text;
|
||
SkipLexem;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadSheet(out s: string): Boolean;
|
||
begin
|
||
Result := ReadString(s) or ReadName(s)
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadString(out s: string): Boolean;
|
||
begin
|
||
Result := Lexem.Kind = flkString;
|
||
|
||
if Result then
|
||
begin
|
||
s := Lexem.Text;
|
||
SkipLexem;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ReadSym(const s: string): Boolean;
|
||
begin
|
||
Result := (Lexem.Kind <> flkVoid) and (Lexem.Text = s);
|
||
|
||
if Result then
|
||
SkipLexem;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseTerm: Boolean;
|
||
begin
|
||
Result :=
|
||
ParseExtArea or
|
||
ParseExtCell or
|
||
ParseFuncCall or
|
||
ParseString or
|
||
ParseNumber or
|
||
ParseNameConst or
|
||
ParseArea or
|
||
ParseCell
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseFormula: Boolean;
|
||
begin
|
||
FRPN.PushFrame;
|
||
Ensure(ParsePPTerm);
|
||
|
||
while ParseBinOp do
|
||
Ensure(ParsePPTerm, 'Expression cannot end with an operator');
|
||
|
||
FRPN.PopFrame;
|
||
Result := True;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseNameConst: Boolean;
|
||
var
|
||
s: string;
|
||
begin
|
||
Save;
|
||
Result := ReadName(s);
|
||
|
||
if Result then
|
||
begin
|
||
s := AnsiUpperCase(s);
|
||
|
||
if s = 'TRUE' then
|
||
Push(fokBool, s, 1)
|
||
|
||
else if s = 'FALSE' then
|
||
Push(fokBool, s, 0)
|
||
|
||
else
|
||
Result := False;
|
||
end;
|
||
|
||
if Result then
|
||
Discard
|
||
else
|
||
Load
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseNumber: Boolean;
|
||
var
|
||
s: string;
|
||
begin
|
||
Result := ReadNumber(s);
|
||
|
||
if Result then
|
||
Push(fokNumber, s);
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParsePostOp: Boolean;
|
||
begin
|
||
if IsOp(Lexem, '%') then
|
||
begin
|
||
FRPN.PushOp(fokDiv100, '%', 1);
|
||
SkipLexem;
|
||
Result := True;
|
||
end
|
||
else
|
||
Result := False
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParsePPTerm: Boolean;
|
||
begin
|
||
ParsePrefOp;
|
||
Ensure(ParseTerm);
|
||
ParsePostOp;
|
||
Result := True;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParsePrefOp: Boolean;
|
||
begin
|
||
if IsOp(Lexem, '-') then
|
||
begin
|
||
FRPN.PushOp(fokNeg, '-', 1);
|
||
SkipLexem;
|
||
Result := True;
|
||
end else if IsOp(Lexem, '+') then
|
||
begin
|
||
SkipLexem;
|
||
Result := True;
|
||
end
|
||
else
|
||
Result := False
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseCell: Boolean;
|
||
var
|
||
t: TBiffFormulaToken;
|
||
begin
|
||
Result := ReadCell(t);
|
||
|
||
if Result then
|
||
Push(fokCell, t.Text, t.Flags);
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseArea: Boolean;
|
||
var
|
||
c1, c2: TBiffFormulaToken;
|
||
begin
|
||
Save;
|
||
Result := ReadCell(c1) and ReadSym(':') and ReadCell(c2);
|
||
|
||
if Result then
|
||
begin
|
||
Discard;
|
||
|
||
FRPN.PushArg(fokCell, c1.Text, c1.Flags);
|
||
FRPN.PushArg(fokCell, c2.Text, c2.Flags);
|
||
FRPN.PushOp(fokArea, ':', 2);
|
||
end
|
||
else
|
||
Load;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseExtArea: Boolean;
|
||
var
|
||
s: string;
|
||
c1, c2: TBiffFormulaToken;
|
||
begin
|
||
Save;
|
||
Result := ReadSheet(s) and ReadSym('!') and ReadCell(c1) and ReadSym(':') and ReadCell(c2);
|
||
|
||
if Result then
|
||
begin
|
||
Discard;
|
||
|
||
FRPN.PushArg(fokString, s);
|
||
FRPN.PushArg(fokCell, c1.Text, c1.Flags);
|
||
FRPN.PushArg(fokCell, c2.Text, c2.Flags);
|
||
FRPN.PushOp(fokExt, '!', 3);
|
||
end
|
||
else
|
||
Load;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseExtCell: Boolean;
|
||
var
|
||
s: string;
|
||
c: TBiffFormulaToken;
|
||
begin
|
||
Save;
|
||
Result := ReadSheet(s) and ReadSym('!') and ReadCell(c);
|
||
|
||
if Result then
|
||
begin
|
||
Discard;
|
||
|
||
FRPN.PushArg(fokString, s);
|
||
FRPN.PushArg(fokCell, c.Text, c.Flags);
|
||
FRPN.PushOp(fokExt, '!', 2);
|
||
end
|
||
else
|
||
Load;
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseString: Boolean;
|
||
var
|
||
s: string;
|
||
begin
|
||
Result := ReadString(s);
|
||
|
||
if Result then
|
||
Push(fokString, s);
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseBinOp: Boolean;
|
||
var
|
||
s: string;
|
||
begin
|
||
Result := ReadOp(s);
|
||
|
||
if Result then
|
||
FRPN.PushOp(OpKind(s), s, 2);
|
||
end;
|
||
|
||
function TBiffFormulaParser.ParseFuncCall: Boolean;
|
||
var
|
||
s: string;
|
||
begin
|
||
Save;
|
||
|
||
if not ReadName(s) then
|
||
s := '';
|
||
|
||
Result := ReadSym('(');
|
||
|
||
if not Result then
|
||
begin
|
||
Load;
|
||
Exit;
|
||
end;
|
||
|
||
FRPN.PushFrame(s);
|
||
|
||
if Lexem.Text <> ')' then
|
||
begin
|
||
Ensure(ParseFormula, 'Argument expected after "("');
|
||
|
||
while IsArgSep(Lexem) do
|
||
begin
|
||
SkipLexem;
|
||
|
||
if IsArgSep(Lexem) then
|
||
Push(fokNull, 'void')
|
||
else
|
||
Ensure(ParseFormula, 'Argument expected after ","');
|
||
end;
|
||
end;
|
||
|
||
Ensure(ReadSym(')'));
|
||
|
||
if s = '' then
|
||
FRPN.PushOp(fokId, 'id', 1);
|
||
|
||
FRPN.PopFrame;
|
||
Discard;
|
||
Result := True;
|
||
end;
|
||
|
||
{ TBiffFormulaCompiler }
|
||
|
||
constructor TBiffFormulaCompiler.Create;
|
||
begin
|
||
FParser := TBiffFormulaParser.Create;
|
||
FEmitter := TBiffFormulaCodeEmitter.Create;
|
||
FCode := TMemoryStream.Create;
|
||
|
||
FEmitter.Output := FCode;
|
||
end;
|
||
|
||
destructor TBiffFormulaCompiler.Destroy;
|
||
begin
|
||
FParser.Free;
|
||
FEmitter.Free;
|
||
FCode.Free;
|
||
inherited;
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.Ensure(b: Boolean; const Fmt: string; const Args: array of const);
|
||
begin
|
||
Ensure(b, Format(Fmt, Args))
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.Ensure(b: Boolean; const ErrorMsg: string);
|
||
begin
|
||
if not b then
|
||
Error('%s', [ErrorMsg])
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.Error(const Fmt: string; const Args: array of const);
|
||
begin
|
||
raise EBiffFormulaCompilerError.CreateFmt(Fmt, Args)
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitArea(const Cell1, Cell2: TBiffFormulaToken);
|
||
begin
|
||
Ensure(IsCell(Cell1) and IsCell(Cell2));
|
||
FEmitter.PushArea(GetCellPos(Cell1), GetCellPos(Cell2));
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitExtArea(const Sheet, Cell1, Cell2: TBiffFormulaToken);
|
||
begin
|
||
Ensure(IsStr(Sheet) and IsCell(Cell1) and IsCell(Cell2));
|
||
FEmitter.PushExtArea(LinkTable.GetInternalSheetRef(Sheet.Text), GetCellPos(Cell1), GetCellPos(Cell2));
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitExtCell(const Sheet, Cell: TBiffFormulaToken);
|
||
begin
|
||
Ensure(IsStr(Sheet) and IsCell(Cell));
|
||
FEmitter.PushExtCell(LinkTable.GetInternalSheetRef(Sheet.Text), GetCellPos(Cell));
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitFunc(Name: string; NumArgs: Integer);
|
||
var
|
||
Func: TBiffFormulaFunc;
|
||
begin
|
||
Assert(Name <> '');
|
||
Name := AnsiUpperCase(Name);
|
||
Ensure(TBiffFormulaFuncList.Exists(Name), 'Function %s is not supported', [Name]);
|
||
|
||
Func := TBiffFormulaFuncList.Get(Name);
|
||
Assert(Func.Name = Name);
|
||
|
||
Ensure((Func.MinArgs <= NumArgs) and (NumArgs <= Func.MaxArgs),
|
||
'Function %s cannot be called with %d arguments', [Name, NumArgs]);
|
||
|
||
if Func.MinArgs = Func.MaxArgs then
|
||
FEmitter.Call(Func.Id)
|
||
else
|
||
FEmitter.Call(Func.Id, NumArgs);
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitIdFunc(NumArgs: Integer);
|
||
begin
|
||
if NumArgs = 1 then
|
||
FEmitter.CallId
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitNum(Num: Double);
|
||
begin
|
||
|
||
{ A number can be compiled in three ways:
|
||
|
||
double(Num) [9 bytes]
|
||
int(Num) [5 bytes]
|
||
int(Num) neg [6 bytes]
|
||
|
||
This method chooses a way that yields the smallest code. }
|
||
|
||
if (Num <> Ceil(Num)) or (Num > $ffff) or (Num < -$ffff) then
|
||
FEmitter.Push(Num)
|
||
else if Num >= 0 then
|
||
FEmitter.Push(Ceil(Num))
|
||
else
|
||
begin
|
||
FEmitter.Push(Ceil(-Num));
|
||
FEmitter.Neg;
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitOp(Kind: TBiffFormulaOperatorKind; NumArgs: Integer);
|
||
begin
|
||
case NumArgs of
|
||
1:
|
||
case Kind of
|
||
fokNeg: FEmitter.Neg;
|
||
fokDiv100: FEmitter.Div100;
|
||
|
||
else Error('Unsupported unary operator %d', [Integer(Kind)]);
|
||
end;
|
||
|
||
2:
|
||
case Kind of
|
||
fokAdd: FEmitter.Add;
|
||
fokSub: FEmitter.Sub;
|
||
fokDiv: FEmitter.Divide;
|
||
fokMul: FEmitter.Mul;
|
||
fokPow: FEmitter.Pow;
|
||
fokL: FEmitter.CmpL;
|
||
fokG: FEmitter.CmpG;
|
||
fokE: FEmitter.CmpE;
|
||
fokNE: FEmitter.CmpNE;
|
||
fokLE: FEmitter.CmpLE;
|
||
fokGE: FEmitter.CmpGE;
|
||
fokIsect: FEmitter.Intersect;
|
||
fokJoin: FEmitter.Join;
|
||
fokColon: FEmitter.Range;
|
||
|
||
else Error('Unsupported binary operator %d', [Integer(Kind)]);
|
||
end;
|
||
|
||
else Error('Unsupported %d-ary operator %d', [NumArgs, Integer(Kind)]);
|
||
end;
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.EmitPush(const t: TBiffFormulaToken);
|
||
|
||
{ StrToFloat gets decimal separator from locale settings.
|
||
Here this separator is always the dot. }
|
||
|
||
function StrToDouble(const s: string): Double;
|
||
var
|
||
p, n: Integer;
|
||
begin
|
||
Assert(s <> '');
|
||
|
||
n := Length(s);
|
||
p := n;
|
||
|
||
while (p > 0) and (s[p] <> '.') do
|
||
Dec(p);
|
||
|
||
if p = 0 then
|
||
Result := StrToInt(s)
|
||
else if p = n then
|
||
Result := StrToInt(Copy(s, 1, n - 1))
|
||
else if p = 1 then
|
||
Result := StrToDouble('0' + s)
|
||
else
|
||
Result := StrToInt(Copy(s, 1, p - 1)) + StrToInt(Copy(s, p + 1, n - p))/Power(10, n - p)
|
||
end;
|
||
|
||
begin
|
||
case t.Op of
|
||
fokNumber:
|
||
EmitNum(StrToDouble(t.Text));
|
||
|
||
fokNull:
|
||
FEmitter.PushNull;
|
||
|
||
fokCell:
|
||
FEmitter.PushCell(GetCellPos(t));
|
||
|
||
fokString:
|
||
FEmitter.Push(t.Text);
|
||
|
||
fokBool:
|
||
FEmitter.Push(t.Flags <> 0);
|
||
|
||
else
|
||
Error('Cannot push value (%s) of type %d', [t.Text, Integer(t.Op)]);
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaCompiler.GetCellPos(const t: TBiffFormulaToken): TBiffFormulaCellRef;
|
||
|
||
{ Converts a column name like GH into a zero based column index }
|
||
|
||
function GetColIndex(const s: string): Integer;
|
||
var
|
||
i, n: Integer;
|
||
begin
|
||
Assert(s <> '');
|
||
|
||
n := 1;
|
||
Result := 0;
|
||
|
||
for i := Length(s) downto 1 do
|
||
begin
|
||
Assert(AnsiChar(s[i]) in ['A'..'Z']);
|
||
Inc(Result, n * (Ord(s[i]) - Ord('A') + 1));
|
||
n := n * 26;
|
||
end;
|
||
|
||
Dec(Result);
|
||
end;
|
||
|
||
var
|
||
i: Integer;
|
||
Ref, ColName, RowName: string;
|
||
begin
|
||
Assert(IsCell(t));
|
||
|
||
Ref := AnsiUpperCase(t.Text);
|
||
i := 1;
|
||
|
||
while AnsiChar(Ref[i]) in ['A'..'Z'] do
|
||
Inc(i);
|
||
|
||
Assert((i > 1) and (i <= Length(Ref)));
|
||
|
||
ColName := Copy(Ref, 1, i - 1);
|
||
RowName := Copy(Ref, i, Length(Ref) - i + 1);
|
||
|
||
with Result do
|
||
begin
|
||
Row := StrToInt(RowName) - 1;
|
||
Col := GetColIndex(ColName);
|
||
AbsRow := t.Flags and 1 > 0;
|
||
AbsCol := t.Flags and 2 > 0;
|
||
end;
|
||
end;
|
||
|
||
function TBiffFormulaCompiler.GetLinkTable: TBiffLinkTable;
|
||
begin
|
||
Result := FLinkTable;
|
||
Ensure(Result <> nil, 'Link table is not assigned');
|
||
end;
|
||
|
||
function TBiffFormulaCompiler.IsCell(const t: TBiffFormulaToken): Boolean;
|
||
begin
|
||
Result := (t.Kind = ftkArg) and (t.Op = fokCell) and (Length(t.Text) > 1)
|
||
end;
|
||
|
||
function TBiffFormulaCompiler.IsStr(const t: TBiffFormulaToken): Boolean;
|
||
begin
|
||
Result := (t.Kind = ftkArg) and (t.Op = fokString)
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.SaveToStream(Stream: TStream);
|
||
begin
|
||
Stream.CopyFrom(FCode, 0)
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.SelectToken(i: Integer);
|
||
begin
|
||
Assert((i >= 0) and (i <= FParser.Count));
|
||
|
||
if i < FParser.Count then
|
||
FEmitter.RetMode := FRetTypes[i];
|
||
|
||
FPos := i;
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.SkipToken;
|
||
begin
|
||
SelectToken(FPos + 1);
|
||
end;
|
||
|
||
function TBiffFormulaCompiler.Token(i: Integer): TBiffFormulaToken;
|
||
begin
|
||
if (FPos + i >= 0) and (FPos + i < FParser.Count) then
|
||
Result := FParser[FPos + i]
|
||
else
|
||
Result.Kind := ftkVoid
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.CalcRetTypes;
|
||
var
|
||
Stack: array of Integer;
|
||
StackTop: Integer;
|
||
|
||
procedure Push(Id: Integer; RepNum: Integer = 1);
|
||
begin
|
||
Assert(RepNum >= 1);
|
||
|
||
for RepNum := RepNum downto 1 do
|
||
begin
|
||
Assert(StackTop < Length(Stack));
|
||
Stack[StackTop] := Id;
|
||
Inc(StackTop);
|
||
end;
|
||
end;
|
||
|
||
procedure Pop(n: Integer);
|
||
begin
|
||
Assert(StackTop >= n);
|
||
Dec(StackTop, n);
|
||
end;
|
||
|
||
function Top(i: Integer): Integer;
|
||
begin
|
||
Assert(StackTop - i - 1 >= 0);
|
||
Result := Stack[StackTop - i - 1];
|
||
end;
|
||
|
||
procedure SetRetType(i: Integer; t: TBiffFormulaRetType);
|
||
begin
|
||
Assert(FRetTypes[i] = frtVoid, 'Ret type is already set');
|
||
FRetTypes[i] := t;
|
||
end;
|
||
|
||
function GetArgType(const t: TBiffFormulaToken; i: Integer): TBiffFormulaRetType;
|
||
begin
|
||
Assert(t.Kind = ftkOp);
|
||
Result := frtVoid;
|
||
|
||
case t.Op of
|
||
fokColon: Result := frtRef;
|
||
fokIsect: Result := frtRef;
|
||
fokFunc:
|
||
case TBiffFormulaFuncList.GetArgType(t.Text, i) of
|
||
'R': Result := frtRef;
|
||
'V': Result := frtVal;
|
||
'A': Result := frtArray;
|
||
end;
|
||
|
||
else Result := frtVal;
|
||
end;
|
||
end;
|
||
|
||
procedure AssignArgTypes(const t: TBiffFormulaToken);
|
||
var
|
||
i: Integer;
|
||
begin
|
||
Assert(StackTop >= t.Flags);
|
||
|
||
for i := 1 to t.Flags do
|
||
SetRetType(Top(t.Flags - i), GetArgType(t, i - 1))
|
||
end;
|
||
|
||
var
|
||
i, n: Integer;
|
||
t: TBiffFormulaToken;
|
||
begin
|
||
n := FParser.Count;
|
||
|
||
SetLength(FRetTypes, n);
|
||
SetLength(Stack, n);
|
||
StackTop := 0;
|
||
|
||
for i := 0 to n - 1 do
|
||
begin
|
||
t := FParser[i];
|
||
|
||
case t.Kind of
|
||
ftkArg:
|
||
Push(i);
|
||
|
||
ftkOp:
|
||
begin
|
||
AssignArgTypes(t);
|
||
Pop(t.Flags);
|
||
Push(i);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
SetRetType(Top(0), frtVal);
|
||
Pop(1);
|
||
Ensure(StackTop = 0, 'Not all tokens produced by parser are supported by compiler');
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.Compile(const s: string);
|
||
begin
|
||
FParser.Formula := s;
|
||
CalcRetTypes;
|
||
SelectToken(0);
|
||
|
||
while FPos < FParser.Count do
|
||
CompileToken
|
||
end;
|
||
|
||
procedure TBiffFormulaCompiler.CompileToken;
|
||
begin
|
||
if Token.Kind = ftkOp then
|
||
case Token.Op of
|
||
fokPush:
|
||
EmitPush(Token(-1));
|
||
|
||
fokId:
|
||
EmitIdFunc(Token.Flags);
|
||
|
||
fokFunc:
|
||
EmitFunc(Token.Text, Token.Flags);
|
||
|
||
fokArea:
|
||
EmitArea(Token(-2), Token(-1));
|
||
|
||
fokExt:
|
||
case Token.Flags of
|
||
2: EmitExtCell(Token(-2), Token(-1));
|
||
3: EmitExtArea(Token(-3), Token(-2), Token(-1));
|
||
|
||
else Error('Operator "!" does not support %d arguments', [Token.Flags]);
|
||
end;
|
||
|
||
fokAdd, fokSub, fokMul, fokDiv, fokPow,
|
||
fokL, fokG, fokLE, fokGE, fokNE, fokE,
|
||
fokIsect, fokJoin, fokColon, fokDiv100, fokNeg:
|
||
EmitOp(Token.Op, Token.Flags);
|
||
|
||
else
|
||
Error('Operator (%s) %d not supported', [Token.Text, Integer(Token.Op)]);
|
||
end;
|
||
|
||
SkipToken;
|
||
end;
|
||
|
||
{ TBiffFormulaFuncList }
|
||
|
||
class function TBiffFormulaFuncList.GetCount: Integer;
|
||
begin
|
||
Result := Length(FuncArray)
|
||
end;
|
||
|
||
class function TBiffFormulaFuncList.GetFunc(i: Integer): TBiffFormulaFunc;
|
||
begin
|
||
Result := FuncArray[i]
|
||
end;
|
||
|
||
class procedure TBiffFormulaFuncList.SetCount(n: Integer);
|
||
begin
|
||
SetLength(FuncArray, n)
|
||
end;
|
||
|
||
class procedure TBiffFormulaFuncList.SetFunc(i: Integer; const f: TBiffFormulaFunc);
|
||
begin
|
||
FuncArray[i] := f
|
||
end;
|
||
|
||
class procedure TBiffFormulaFuncList.Add(Id: Integer; Name: string; MinArgs,
|
||
MaxArgs: Integer; RetType: Char; ArgTypes: string; Volatile: Boolean);
|
||
|
||
function IsValid(const s: string): Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
for i := 1 to Length(s) do
|
||
if not (AnsiChar(s[i]) in ['r', 'v', 'a']) then
|
||
begin
|
||
Result := False;
|
||
Exit;
|
||
end;
|
||
|
||
Result := True;
|
||
end;
|
||
|
||
var
|
||
f: TBiffFormulaFunc;
|
||
begin
|
||
Assert(Name <> '');
|
||
Assert((MinArgs >= 0) and (MaxArgs >= MinArgs));
|
||
Assert(IsValid(RetType));
|
||
Assert(IsValid(ArgTypes));
|
||
|
||
if MaxArgs > 0 then
|
||
Assert(ArgTypes <> '');
|
||
|
||
f.Name := AnsiUpperCase(Name);
|
||
f.Id := Id;
|
||
f.MinArgs := MinArgs;
|
||
f.MaxArgs := MaxArgs;
|
||
f.Volatile := Volatile;
|
||
f.RetType := RetType;
|
||
f.ArgTypes := ArgTypes;
|
||
|
||
Add(f);
|
||
end;
|
||
|
||
class function TBiffFormulaFuncList.Find(Name: string): Integer;
|
||
begin
|
||
Name := AnsiUpperCase(Name);
|
||
|
||
for Result := 0 to GetCount - 1 do
|
||
if GetFunc(Result).Name >= Name then
|
||
Exit;
|
||
|
||
Result := GetCount;
|
||
end;
|
||
|
||
class procedure TBiffFormulaFuncList.Add(const f: TBiffFormulaFunc);
|
||
var
|
||
i, j: Integer;
|
||
begin
|
||
i := Find(f.Name);
|
||
Assert((i = GetCount) or (GetFunc(i).Name > f.Name), f.Name + ' already added');
|
||
SetCount(GetCount + 1);
|
||
|
||
for j := GetCount - 1 downto i + 1 do
|
||
SetFunc(j, GetFunc(j - 1));
|
||
|
||
SetFunc(i, f);
|
||
end;
|
||
|
||
class function TBiffFormulaFuncList.Get(const Name: string): TBiffFormulaFunc;
|
||
begin
|
||
Init;
|
||
Result := GetFunc(Find(Name))
|
||
end;
|
||
|
||
class function TBiffFormulaFuncList.GetArgType(const Name: string; i: Integer): Char;
|
||
begin
|
||
with Get(Name) do
|
||
begin
|
||
Assert((i >= 0) and (i < MaxArgs));
|
||
|
||
if i + 1 <= Length(ArgTypes) then
|
||
Result := ArgTypes[i + 1]
|
||
else
|
||
Result := ArgTypes[Length(ArgTypes)];
|
||
|
||
Result := UpperCase(Result)[1];
|
||
Assert(AnsiChar(Result) in ['R', 'V', 'A']);
|
||
end;
|
||
end;
|
||
|
||
class function TBiffFormulaFuncList.Exists(const Name: string): Boolean;
|
||
var
|
||
i: Integer;
|
||
begin
|
||
Init;
|
||
i := Find(Name);
|
||
|
||
Result := (i < GetCount) and (GetFunc(i).Name = Name)
|
||
end;
|
||
|
||
class procedure TBiffFormulaFuncList.Init;
|
||
begin
|
||
if GetCount > 0 then
|
||
Exit;
|
||
|
||
{ http://sc.openoffice.org/excelfileformat.pdf
|
||
http://msdn.microsoft.com/en-us/library/dd904817.aspx }
|
||
|
||
Add(0, 'count', 1, 30, 'v', 'r');
|
||
Add(1, 'if', 2, 3, 'r', 'vr');
|
||
Add(2, 'isna', 1, 1, 'v', 'v');
|
||
Add(3, 'iserror', 1, 1, 'v', 'v');
|
||
Add(4, 'sum', 1, 30, 'v', 'r');
|
||
Add(5, 'average', 1, 30, 'v', 'r');
|
||
Add(6, 'min', 1, 30, 'v', 'r');
|
||
Add(7, 'max', 1, 30, 'v', 'r');
|
||
Add(8, 'row', 0, 1, 'v', 'r');
|
||
Add(9, 'column', 0, 1, 'v', 'r');
|
||
Add(10, 'na', 0, 0, 'v', '');
|
||
|
||
Add(13, 'dollar', 1, 2, 'v', 'v');
|
||
Add(14, 'fixed', 2, 2, 'v', 'v');
|
||
|
||
Add(20, 'sqrt', 1, 1, 'v', 'v');
|
||
Add(21, 'exp', 1, 1, 'v', 'v');
|
||
Add(22, 'ln', 1, 1, 'v', 'v');
|
||
Add(23, 'log10', 1, 1, 'v', 'v');
|
||
Add(24, 'abs', 1, 1, 'v', 'v');
|
||
Add(25, 'int', 1, 1, 'v', 'v');
|
||
Add(26, 'sign', 1, 1, 'v', 'v');
|
||
Add(27, 'round', 2, 2, 'v', 'v');
|
||
Add(28, 'lookup', 2, 3, 'v', 'vr');
|
||
Add(29, 'index', 2, 4, 'r', 'rv');
|
||
Add(30, 'rept', 2, 2, 'v', 'v');
|
||
Add(31, 'mid', 3, 3, 'v', 'v');
|
||
Add(32, 'len', 1, 1, 'v', 'v');
|
||
Add(33, 'value', 1, 1, 'v', 'v');
|
||
Add(34, 'true', 0, 0, 'v', '');
|
||
Add(35, 'false', 0, 0, 'v', '');
|
||
Add(36, 'and', 1, 30, 'v', 'r');
|
||
Add(37, 'or', 1, 30, 'v', 'r');
|
||
Add(38, 'not', 1, 1, 'v', 'v');
|
||
Add(39, 'mod', 2, 2, 'v', 'v');
|
||
|
||
Add(48, 'text', 2, 2, 'v', 'v');
|
||
|
||
Add(63, 'rand', 0, 0, 'v', '');
|
||
Add(64, 'match', 2, 3, 'v', 'vr');
|
||
Add(65, 'date', 3, 3, 'v', 'v');
|
||
Add(66, 'time', 3, 3, 'v', 'v');
|
||
Add(67, 'day', 1, 1, 'v', 'v');
|
||
Add(68, 'month', 1, 1, 'v', 'v');
|
||
Add(69, 'year', 1, 1, 'v', 'v');
|
||
Add(70, 'weekday', 1, 2, 'v', 'v');
|
||
Add(71, 'hour', 1, 1, 'v', 'v');
|
||
Add(72, 'minute', 1, 1, 'v', 'v');
|
||
Add(73, 'second', 1, 1, 'v', 'v');
|
||
Add(74, 'now', 0, 0, 'v', '');
|
||
Add(75, 'areas', 1, 1, 'v', 'r');
|
||
Add(76, 'rows', 1, 1, 'v', 'r');
|
||
Add(77, 'columns', 1, 1, 'v', 'r');
|
||
Add(78, 'offset', 3, 5, 'r', 'rv');
|
||
Add(79, 'absref', 2, 2, 'r', 'vr');
|
||
Add(80, 'relref', 2, 2, 'r', 'rr');
|
||
|
||
Add(82, 'search', 2, 3, 'v', 'v');
|
||
Add(83, 'transpose', 1, 1, 'a', 'a');
|
||
Add(84, 'error', 0, 2, 'v', 'v');
|
||
|
||
Add(86, 'type', 1, 1, 'v', 'v');
|
||
Add($5a, 'deref', 1, 1, 'v', 'r');
|
||
|
||
Add(100, 'choose', 2, 30, 'r', 'vr');
|
||
Add(101, 'hlookup', 3, 4, 'v', 'vrrv');
|
||
Add(102, 'vlookup', 3, 4, 'v', 'vrrv');
|
||
|
||
Add(105, 'isref', 1, 1, 'v', 'r');
|
||
Add(109, 'log', 1, 2, 'v', 'v');
|
||
|
||
Add(111, 'char', 1, 1, 'v', 'v');
|
||
Add(112, 'lower', 1, 1, 'v', 'v');
|
||
Add(113, 'upper', 1, 1, 'v', 'v');
|
||
|
||
Add(115, 'left', 1, 2, 'v', 'v');
|
||
Add(116, 'right', 1, 2, 'v', 'v');
|
||
Add(117, 'exact', 2, 2, 'v', 'v');
|
||
Add(118, 'trim', 1, 2, 'v', 'v');
|
||
Add(119, 'replace', 4, 4, 'v', 'v');
|
||
Add(120, 'substitute', 3, 4, 'v', 'v');
|
||
Add(121, 'code', 1, 1, 'v', 'v');
|
||
|
||
Add(124, 'find', 2, 3, 'v', 'v');
|
||
Add(125, 'cell', 1, 2, 'v', 'vr', True);
|
||
Add(126, 'iserr', 1, 1, 'v', 'v');
|
||
Add(127, 'istext', 1, 1, 'v', 'v');
|
||
Add(128, 'isnumber', 1, 1, 'v', 'v');
|
||
Add(129, 'isblank', 1, 1, 'v', 'v');
|
||
Add(130, 't', 1, 1, 'v', 'r');
|
||
Add(131, 'n', 1, 1, 'v', 'r');
|
||
|
||
Add(140, 'datevalue', 1, 1, 'v', 'v');
|
||
Add(141, 'timevalue', 1, 1, 'v', 'v');
|
||
|
||
Add(147, 'textref', 1, 2, 'r', 'v');
|
||
Add(148, 'indirect', 1, 2, 'r', 'v');
|
||
|
||
Add(162, 'clean', 1, 1, 'v', 'v');
|
||
Add(169, 'counta', 0, 30, 'v', 'r');
|
||
Add(190, 'isnontext', 1, 1, 'v', 'v');
|
||
|
||
Add(197, 'trunc', 1, 2, 'v', 'v');
|
||
Add(198, 'islogical', 1, 1, 'v', 'v');
|
||
|
||
Add(205, 'findb', 2, 3, 'v', 'v');
|
||
Add(206, 'searchb', 2, 3, 'v', 'v');
|
||
Add(207, 'replaceb', 4, 4, 'v', 'v');
|
||
Add(208, 'leftb', 1, 2, 'v', 'v');
|
||
Add(209, 'rightb', 1, 2, 'v', 'v');
|
||
Add(210, 'midb', 3, 3, 'v', 'v');
|
||
Add(211, 'lenb', 1, 1, 'v', 'v');
|
||
Add(212, 'roundup', 2, 2, 'v', 'v');
|
||
Add(213, 'rounddown', 2, 2, 'v', 'v');
|
||
|
||
Add(219, 'address', 2, 5, 'v', 'v');
|
||
Add(221, 'today', 0, 0, 'v', '', True);
|
||
Add(257, 'evaluate', 1, 1, 'v', 'v');
|
||
Add(261, 'error.type', 1, 1, 'v', 'v');
|
||
Add(277, 'confidence', 3, 3, 'v', 'v');
|
||
Add(279, 'even', 1, 1, 'v', 'v');
|
||
Add(285, 'floor', 2, 2, 'v', 'v');
|
||
Add(288, 'ceiling', 2, 2, 'v', 'v');
|
||
Add(298, 'odd', 1, 1, 'v', 'v');
|
||
|
||
Add(336, 'concatenate', 0, 30, 'v', 'v');
|
||
Add(337, 'power', 2, 2, 'v', 'v');
|
||
|
||
Add(344, 'subtotal', 2, 30, 'v', 'vr');
|
||
Add(345, 'sumif', 2, 3, 'v', 'rvr');
|
||
Add(346, 'countif', 2, 2, 'v', 'rv');
|
||
Add(347, 'countblank', 1, 1, 'v', 'r');
|
||
|
||
Add(350, 'ispmt', 4, 4, 'v', 'v');
|
||
Add(351, 'dateif', 3, 3, 'v', 'v');
|
||
Add(352, 'datestring', 1, 1, 'v', 'v');
|
||
Add(353, 'numberstring', 2, 2, 'v', 'v');
|
||
|
||
Add(359, 'hyperlink', 1, 2, 'v', 'v');
|
||
|
||
Add(362, 'maxa', 1, 30, 'v', 'r');
|
||
Add(363, 'mina', 1, 30, 'v', 'r');
|
||
end;
|
||
|
||
function TRectangle.GetBottom: Integer;
|
||
begin
|
||
Result := FRect.Bottom;
|
||
end;
|
||
|
||
function TRectangle.GetBottomRight: TPoint;
|
||
begin
|
||
Result := FRect.BottomRight;
|
||
end;
|
||
|
||
function TRectangle.GetLeft: Integer;
|
||
begin
|
||
Result := FRect.Left;
|
||
end;
|
||
|
||
function TRectangle.GetRight: Integer;
|
||
begin
|
||
Result := FRect.Right;
|
||
end;
|
||
|
||
function TRectangle.GetTop: Integer;
|
||
begin
|
||
Result := FRect.Top;
|
||
end;
|
||
|
||
function TRectangle.GetTopLeft: TPoint;
|
||
begin
|
||
Result := FRect.TopLeft;
|
||
end;
|
||
|
||
procedure TRectangle.SetBottom(const Value: Integer);
|
||
begin
|
||
FRect.Bottom := Value;
|
||
end;
|
||
|
||
procedure TRectangle.SetBottomRight(const Value: TPoint);
|
||
begin
|
||
FRect.BottomRight := Value;
|
||
end;
|
||
|
||
procedure TRectangle.SetLeft(const Value: Integer);
|
||
begin
|
||
FRect.Left := Value;
|
||
end;
|
||
|
||
procedure TRectangle.SetRight(const Value: Integer);
|
||
begin
|
||
FRect.Right := Value;
|
||
end;
|
||
|
||
procedure TRectangle.SetTop(const Value: Integer);
|
||
begin
|
||
FRect.Top := Value;
|
||
end;
|
||
|
||
procedure TRectangle.SetTopLeft(const Value: TPoint);
|
||
begin
|
||
FRect.TopLeft := Value;
|
||
end;
|
||
|
||
end.
|