Freeform Excel Worksheet (No OLE or EXCEL required)

Question/Problem/Abstract:

See also : Article_3475.asp - (TDataSet to Excel)

This Class allows you to create an Excel Worksheet in much the

same way as you create a TStringGrid. ie. Cell[Column,Row].

-------------------------------------------------------------------------

Features

-------------------------------------------------------------------------

Freeform cell access with DataType,FontIndex,FormatString,

Alignment,Pattern and BorderStyle.

NOTE : The col and row indexes are ZERO based in the same way

as cells in a TStringGrid

4 Mapable system fonts (Preset to

Default = Arial 10 regular : FontIndex = 0

Alt_1 = Arial 10 bold : FontIndex = 1

Alt_2 = Courier New 11 regular : FontIndex = 2

Alt_3 = Courier New 11 bold : FontIndex = 3

User definable cell formats using Excel syntax (Defaults set to

String = 'General'

Integer = '0'

Double = '###,###,##0.00'

DateTime = 'dd-mmm-yyyy hh:mm:ss'

Date = 'dd-mmm-yyyy'

Time = 'hh:mm:ss'

Set individual Column Widths and Row Heights.

-------------------------------------------------------------------------

Example Code Snippet

-------------------------------------------------------------------------

uses MahWorksheet;

procedure ExcelDemo;

var i : integer;

oWorksheet : TExcelWorkSheet;

oCell : TExcelCell;

begin

oWorksheet := TExcelWorkSheet.Create;

// Override mappable font 2 and 3

oWorksheet.SetFont_2('Times Roman',12, [fsBold,fsUnderline],XL_BLUE);

oWorksheet.SetFont_3('Ms Serif'); // accept other defaults

// Set a column width

oWorksheet.ColumnWidth(3,50); // Excel Col D

// Set a row height

oWorksheet.RowHeight(25,40); // Excel Row 26

oWorksheet.RowHeight(26,30); // Excel Row 27

// Set a cell via the procedural way

oWorksheet.SetCell(3,25,xlString,'Hello World',XL_FONT_2,

'General',xalLeft,true,[xbTop,xbBottom]);

// Do the same thing via object oriented

oCell := oWorksheet.NewCell(3,16);

oCell.DataType := xlDateTime;

oCell.Data := Now;

// Change the data in cell

oCell := oWorksheet.GetCell(3,25);

oCell.Data := 'Hello World with Borders';

oCell.BorderStyle := [xbLeft,xbRight,xbTop,xbBottom];

oCell.Align := xalCenter;

// Write out a column of integers

for i := 1000 to 1255 do begin

oCell := oWorksheet.NewCell(6,i - 1000);

oCell.DataType := xlInteger;

oCell.Data := i;

oCell.FormatString := '###,##0'; // overide default '0'

oCell.FontIndex := XL_FONT_1;

end;

// Blank out a cell

oWorksheet.BlankCell(6,20);

// Save our work

oWorksheet.SaveToFile('c:\temp\test');

FreeAndNil(oWorksheet);

end;

Answer:

unit MahWorksheet;

interface

uses Windows, Classes, SysUtils, Math, Variants, Graphics;

// =========================================================================

// Microsoft Excel Worksheet Class

// Excel 2.1 BIFF2 Specification

// Mike Heydon 2007

// ---------------------------------------------------------------------

// PUBLIC Methods

// ---------------------------------------------------------------------

// function GetCell(ACol,ARow : word) : TExcelCell;

// function NewCell(ACol,ARow :word) : TExcelCell;

// function GetFont_Default : TExcelFont;

// function GetFont_1 : TExcelFont;

// function GetFont_2 : TExcelFont;

// function GetFont_3 : TExcelFont;

// procedure SetFont_Default(const AFontName : string;

// AFontSize : byte = 10;

// AFontStyle : TFontStyles = [];

// AFontColor : word = 0);

// procedure SetFont_1(const AFontName : string;

// AFontSize : byte = 10;

// AFontStyle : TFontStyles = [];

// AFontColor : word = 0);

// procedure SetFont_2(const AFontName : string;

// AFontSize : byte = 10;

// AFontStyle : TFontStyles = [];

// AFontColor : word = 0);

// procedure SetFont_3(const AFontName : string;

// AFontSize : byte = 10;

// AFontStyle : TFontStyles = [];

// AFontColor : word = 0);

// procedure BlankCell(ACol,ARow : word);

// procedure SetCell(ACol,ARow : word;

// ADataType : TExcelDataType;

// AData : Olevariant;

// AFontIndex : byte = 0;

// AFormatString : string = 'General';

// AAlign : TExcelCellAlign = xalGeneral;

// AHasPattern : boolean = false;

// ABorderStyle : TExcelBorders = []);

// procedure ColumnWidth(ACol : byte; AWidth : word);

// procedure RowHeight(ARow : word; AHeight : byte);

// procedure SaveToFile(const AFileName : string);

// =========================================================================

const

// Font Types - 4 Mapable Fonts - TExcelCell.FontIndex

XL_FONT_DEFAULT = 0;

XL_FONT_1 = 1;

XL_FONT_2 = 2;

XL_FONT_3 = 3;

// Font Colors

XL_BLACK : word = $0000;

XL_WHITE : word = $0001;

XL_RED : word = $0002;

XL_GREEN : word = $0003;

XL_BLUE : word = $0004;

XL_YELLOW : word = $0005;

XL_MAGENTA : word = $0006;

XL_CYAN : word = $0007;

XL_SYSTEM : word = $7FFF;

type

// Border Styles used by TExcelCell.BorderStyle

TExcelBorderType = (xbLeft,xbRight,xbTop,xbBottom);

TExcelBorders = set of TExcelBorderType;

// Data types used by TExcelCell.DataType

TExcelDataType = (xlDouble,xlInteger,xlDate,xlTime,

xlDateTime,xlString);

// Cell Alignment used by TExcelCell.Align

TExcelCellAlign = (xalGeneral,xalLeft,xalCenter,xalRight);

// Structure Returned by GetFont_?()

TExcelFont = record

FontName : string;

FontSize : byte;

FontStyle : TFontStyles;

FontColor : word;

end;

// Cell object of a TExcelWorkSheet

TExcelCell = class(TObject)

private

FRow,FCol : word;

public

DataType : TExcelDataType;

Data : Olevariant;

FontIndex : byte;

FormatString : string;

Align : TExcelCellAlign;

HasPattern : boolean;

BorderStyle : TExcelBorders;

constructor Create;

end;

// Main TExcelWorkSheet Class

TExcelWorkSheet = class(TObject)

private

FFile : file;

FMaxRow,FMaxCol : word;

FRowHeights,FFontTable,

FUsedRows,FFormats,

FColWidths,FCells : TStringList;

function _GetFont(AFontNum : byte) : TExcelFont;

function _CalcSize(AIndex : integer) : word;

procedure _SetColIdx(AListIdx : integer; ARow : word;

out AFirst : word; out ALast : word);

procedure _SaveFontTable;

procedure _SaveColWidths;

procedure _SaveFormats;

procedure _SaveDimensions;

procedure _SaveRowBlocks;

procedure _SaveCells(ARowFr,ARowTo : word);

procedure _WriteToken(AToken : word; ADataLen : word);

procedure _WriteFont(const AFontName : string; AFontHeight,

AAttribute : word);

procedure _SetFont(AFontNum : byte; const AFontName : string;

AFontSize : byte; AFontStyle : TFontStyles;

AFontColor : word);

public

constructor Create;

destructor Destroy; override;

function GetCell(ACol,ARow : word) : TExcelCell;

function NewCell(ACol,ARow :word) : TExcelCell;

function GetFont_Default : TExcelFont;

function GetFont_1 : TExcelFont;

function GetFont_2 : TExcelFont;

function GetFont_3 : TExcelFont;

procedure SetFont_Default(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

procedure SetFont_1(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

procedure SetFont_2(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

procedure SetFont_3(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

procedure BlankCell(ACol,ARow : word);

procedure SetCell(ACol,ARow : word;

ADataType : TExcelDataType;

AData : Olevariant;

AFontIndex : byte = 0;

AFormatString : string = 'General';

AAlign : TExcelCellAlign = xalGeneral;

AHasPattern : boolean = false;

ABorderStyle : TExcelBorders = []);

procedure ColumnWidth(ACol : byte; AWidth : word);

procedure RowHeight(ARow : word; AHeight : byte);

procedure SaveToFile(const AFileName : string);

end;

// -----------------------------------------------------------------------------

implementation

const

// XL Tokens

XL_DIM : word = $0000;

XL_BOF : word = $0009;

XL_EOF : word = $000A;

XL_ROW : word = $0008;

XL_DOCUMENT : word = $0010;

XL_FORMAT : word = $001E;

XL_COLWIDTH : word = $0024;

XL_FONT : word = $0031;

XL_FONTCOLOR : word = $0045;

// XL Cell Types

XL_INTEGER = $02;

XL_DOUBLE = $03;

XL_STRING = $04;

type

// Used when writing in RowBlock mode

TRowRec = packed record

RowIdx,FirstCell,LastCell : word;

Height : word;

NotUsed : word;

Defs : byte;

OSet : word;

end;

// =========================================================================

// Free Form Excel Spreadsheet

// =========================================================================

// =========================================================

// Create a ne Excel Cell Object and initialise defaults

// =========================================================

constructor TExcelCell.Create;

begin

inherited Create;

FRow := 0;

FCol := 0;

DataType := xlString;

FontIndex := 0;

FormatString := 'General';

Align := xalGeneral;

HasPattern := false;

BorderStyle := [];

end;

// ==============================================

// Create and Destroy TExcelWorkSheet Class

// ==============================================

constructor TExcelWorkSheet.Create;

begin

inherited Create;

FColWidths := TStringList.Create;

FRowHeights := TStringList.Create;

FUsedRows := TStringList.Create;

FUsedRows.Sorted := true;

FUsedRows.Duplicates := dupIgnore;

FFormats := TStringList.Create;

FFormats.Sorted := true;

FFormats.Duplicates := dupIgnore;

FCells := TStringList.Create;

FCells.Sorted := true;

FCells.Duplicates := dupIgnore;

FFontTable := TStringList.Create;

FFontTable.AddObject('Arial|10|0',nil);

FFontTable.AddObject('Arial|10|1',nil);

FFontTable.AddObject('Courier New|11|0',nil);

FFontTable.AddObject('Courier New|11|1',nil);

end;

destructor TExcelWorkSheet.Destroy;

var i : integer;

begin

for i := 0 to FCells.Count - 1 do

TExcelCell(FCells.Objects[i]).Free;

FreeAndNil(FCells);

FreeAndNil(FColWidths);

FreeAndNil(FFormats);

FreeAndNil(FFontTable);

FreeAndNil(FUsedRows);

FreeAndNil(FRowHeights);

inherited Destroy;

end;

// =====================================================

// INTERNAL - Write out a Token and Data length record

// =====================================================

procedure TExcelWorkSheet._WriteToken(AToken : word; ADataLen : word);

var aWord : array [0..1] of word;

begin

aWord[0] := AToken;

aWord[1] := ADataLen;

Blockwrite(FFile,aWord,SizeOf(aWord));

end;

// =======================================

// INTERNAL - Write out a FONT record

// =======================================

procedure TExcelWorksheet._WriteFont(const AFontName : string;

AFontHeight,AAttribute : word);

var iLen : byte;

begin

AFontHeight := AFontHeight * 20;

_WriteToken(XL_FONT,5 + length(AFontName));

BlockWrite(FFile,AFontHeight,2);

BlockWrite(FFile,AAttribute,2);

iLen := length(AFontName);

BlockWrite(FFile,iLen,1);

BlockWrite(FFile,AFontName[1],iLen);

end;

// ====================================================================

// INTERNAL - Write out the Font Table

// Also create a table of used rows and rows that have height changed.

// Also set the Max Row and Col used for DIMENSION Record

// Also create the user defined format strings table

// ====================================================================

procedure TExcelWorkSheet._SaveFontTable;

var i,iAttr,iSize,

iRow,iIdx : integer;

iColor : word;

sKey,sName : string;

oCell : TexcelCell;

begin

FMaxRow := 0;

FMaxCol := 0;

FFormats.Clear;

FUsedRows.Clear;

// Add any new formats - Get Unique Rows Used

for i := 0 to FCells.Count - 1 do begin

oCell := TExcelCell(FCells.Objects[i]);

if not SameText('General',oCell.FormatString) then

FFormats.Add(oCell.FormatString);

FUsedRows.Add(FormatFloat('00000',oCell.FRow));

FMaxRow := Min(oCell.FRow,$FFFF);

FMaxCol := Min(oCell.FCol,$FFFF);

end;

// Add any custom row heights

for i := 0 to FRowHeights.Count - 1 do begin

iRow := StrToInt(FRowHeights[i]);

sKey := FormatFloat('00000',iRow);

iSize := word(FRowHeights.Objects[i]);

if FUsedRows.Find(sKey,iIdx) then

FUsedRows.Objects[iIdx] := TObject(iSize)

else

FUsedRows.AddObject(sKey,TObject(iSize));

end;

// Write Font Table

for i := 0 to FFontTable.Count - 1 do begin

sKey := FFontTable[i];

sName := copy(sKey,1,pos('|',sKey) - 1);

sKey := copy(sKey,pos('|',skey) + 1,2096);

iSize := StrToInt(copy(sKey,1,pos('|',sKey) - 1));

iAttr := StrToInt(copy(sKey,pos('|',skey) + 1,2096));

_WriteFont(sName,iSize,iAttr);

_WriteToken(XL_FONTCOLOR,2);

iColor := word(FFontTable.Objects[i]);

Blockwrite(FFile,iColor,2);

end;

// ========================================================

// INTERNAL - Write out the default + user format strings

// ========================================================

procedure TExcelWorkSheet._SaveFormats;

var i : integer;

iLen : byte;

sFormat : string;

begin

// FFormats already loaded in _SaveFontTable

FFormats.Add('0'); // Integer Default

FFormats.Add('###,###,##0.00'); // Double Default

FFormats.Add('dd-mmm-yyyy hh:mm:ss'); // DateTime Default

FFormats.Add('dd-mmm-yyyy'); // Date Default

FFormats.Add('hh:mm:ss'); // Time default

// Add General Default index 0

sFormat := 'General';

_WriteToken(XL_FORMAT,1 + length(sFormat));

iLen := length(sFormat);

Blockwrite(FFile,iLen,1);

Blockwrite(FFile,sFormat[1],iLen);

for i := 0 to FFormats.Count - 1 do begin

sFormat := trim(FFormats[i]);

if not SameText(sFormat,'General') then begin

_WriteToken(XL_FORMAT,1 + length(sFormat));

iLen := length(sFormat);

Blockwrite(FFile,iLen,1);

Blockwrite(FFile,sFormat[1],iLen);

end;

// =============================================

// INTERNAL - Write out DIMENSION Record

// =============================================

procedure TExcelWorkSheet._SaveDimensions;

var aDIMBuffer : array [0..3] of word;

begin

_WriteToken(XL_DIM,8);

aDIMBuffer[0] := 0;

aDIMBuffer[1] := FMaxRow;

aDIMBuffer[2] := 0;

aDIMBuffer[3] := FMaxCol;

Blockwrite(FFile,aDIMBuffer,SizeOf(aDIMBuffer));

end;

// =====================================

// INTERNAL - Save Cell Records

// =====================================

procedure TExcelWorkSheet._SaveCells(ARowFr,ARowTo : word);

var i,iIdx : integer;

iRow,iCol : word;

iDataLen,iFmtIdx,

iBorders,

iShade,iAlign,

iFntIdx,iFmtFnt : byte;

oCell : TExcelCell;

dDblData : double;

sStrData : string;

aAttributes : array [0..2] of byte;

begin

aAttributes[0] := 0; // No reference to XF

for i := 0 to FCells.Count - 1 do begin

oCell := TExcelCell(FCells.Objects[i]);

// Row and Col resolve

iRow := oCell.FRow;

if iRow >= ARowFr then begin

if iRow > ARowTo then break;

iCol := oCell.FCol;

if iCol > 255 then iCol := 255;

// Format IDX resolve - set defaults for numerics/dates

iFmtIdx := 0;

if SameText('General',oCell.FormatString) and

(oCell.DataType <> xlString) then begin

case oCell.DataType of

xlInteger : oCell.FormatString := '0';

xlDateTime : oCell.FormatString := 'dd-mmm-yyyy hh:mm:ss';

xlTime : oCell.FormatString := 'hh:mm:ss';

xlDate : oCell.FormatString := 'dd-mmm-yyyy';

xlDouble : oCell.FormatString := '###,###,##0.00';

end;

if FFormats.Find(oCell.FormatString,iIdx) then begin

if iIdx > 62 then iIdx := 62;

iFmtIdx := iIdx + 1;

end;

// Font IDX resolve and or with format

iFntIdx := oCell.FontIndex shl 6;

iFmtFnt := iFmtIdx or iFntIdx;

// Shading and alignment and borders

iShade := 0;

if oCell.HasPattern then iShade := $80;

iAlign := byte(oCell.Align);

iBorders := 0;

if xbLeft in oCell.BorderStyle then iBorders := iBorders or $08;

if xbRight in oCell.BorderStyle then iBorders := iBorders or $10;

if xbTop in oCell.BorderStyle then iBorders := iBorders or $20;

if xbBottom in oCell.BorderStyle then iBorders := iBorders or $40;

// Resolve Data Type

case oCell.DataType of

xlInteger,

xlDateTime,

xlTime,

xlDate,

xlDouble : begin

dDblData := oCell.Data;

iDataLen := SizeOf(double);

_WriteToken(XL_DOUBLE,15);

_WriteToken(iRow,iCol);

aAttributes[1] := iFmtFnt;

aAttributes[2] := iAlign or iShade or iBorders;

Blockwrite(FFile,aAttributes,SizeOf(aAttributes));

Blockwrite(FFile,dDblData,iDatalen);

end;

xlString : begin

sStrData := oCell.Data;

iDataLen := length(sStrData);

_WriteToken(XL_STRING,iDataLen + 8);

_WriteToken(iRow,iCol);

aAttributes[1] := iFmtFnt;

aAttributes[2] := iAlign or iShade or iBorders;

Blockwrite(FFile,aAttributes,SizeOf(aAttributes));

Blockwrite(FFile,iDataLen,SizeOf(iDataLen));

if iDataLen > 0 then Blockwrite(FFile,sStrData[1],iDataLen);

end;

// =======================================================

// INTERNAL - Calulate the size of the cell record + data

// =======================================================

function TExcelWorkSheet._CalcSize(AIndex : integer) : word;

var iResult : word;

oCell : TExcelCell;

begin

iResult := 0;

oCell := TExcelCell(FCells.Objects[AIndex]);

case oCell.DataType of

xlInteger,

xlDateTime,

xlTime,

xlDate,

xlDouble : iResult := 19;

xlString : iResult := length(oCell.Data) + 12;

end;

Result := iResult;

end;

// ================================================================

// INTERNAL - Fint fisrt and last used column ro ROW Record

// Only used when writing in RowBlock mode (_SaveRowBlocks)

// ================================================================

procedure TExcelWorkSheet._SetColIdx(AListIdx : integer;

ARow : word;

out AFirst : word;

out ALast : word);

var sKey : string;

i,iIdx,

iRow : integer;

iDataSize : word;

begin

FUsedRows.Objects[AListIdx] := nil;

iDataSize := 0;

iIdx := -1;

AFirst := 0;

ALast := 0;

// Find first row-col combo

for i := 0 to FCells.Count - 1 do begin

sKey := FCells[i];

iRow := StrToInt('$' + copy(sKey,1,4));

if iRow = ARow then begin

iIdx := i;

break;

end;

// Found rows?

if iIdx >= 0 then begin

AFirst := StrToInt('$' + copy(sKey,5,4));

ALast := AFirst;

inc(iDataSize,_CalcSize(iIdx));

inc(iIdx);

// Repeat until last row-col

if iIdx < FCells.Count then begin

while true do begin

sKey := FCells[iIdx];

iRow := StrToInt('$' + copy(sKey,1,4));

if iRow = ARow then begin

ALast := StrToInt('$' + copy(sKey,5,4));

inc(iDataSize,_CalcSize(iIdx));

end

else

break;

inc(iIdx);

if iIdx = FCells.Count then break;

end;

inc(ALast);

FUsedRows.Objects[AListIdx] := TObject(iDataSize);

end;

// ==================================================================

// INTERNAL - Write out row/cells in ROWBLOCK format

// NOTE : This mode is onley used when at least 1 row has

// had it's height set by SetRowHeight(), otherwise _SaveCell()

// is run from first to last cells in sheet (faster)

// ==================================================================

procedure TExcelWorkSheet._SaveRowBlocks;

const aWINDOW1 : array [0..13] of byte = ($3d,$00,$0A,$00,$68,$01,$D2,

$00,$DC,$41,$B8,$29,$00,$00);

var i,iArrIdx,

iIdx,iCount,iLoop : integer;

iFirst,iLast,iHeight : word;

aAttributes : array [0..2] of byte;

aRowRec : array of TRowRec;

begin

aAttributes[0] := 0; // No reference to XF

iLoop := 0;

// Process in blocks of 32 rows

while true do begin

iArrIdx := 0;

if iLoop + 31 < FUsedRows.Count - 1 then begin

iCount := iLoop + 31;

SetLength(aRowRec,32);

end

else begin

iCount := FUsedRows.Count - 1;

SetLength(aRowRec,iCount - iLoop + 1);

end;

for i := iLoop to iCount do begin

aRowRec[iArrIdx].RowIdx := StrToInt(FUsedRows[i]);

_SetColIdx(i,aRowRec[iArrIdx].RowIdx,iFirst,iLast);

aRowRec[iArrIdx].FirstCell := iFirst;

aRowRec[iArrIdx].LastCell := iLast;

aRowRec[iArrIdx].Defs := 0;

aRowRec[iArrIdx].NotUsed := 0;

aRowRec[iArrIdx].Height := $80FF;

iIdx := FRowHeights.IndexOf(IntToStr(aRowRec[iArrIdx].RowIdx));

if iIdx <> -1 then begin

iHeight := word(FRowHeights.Objects[iIdx]);

if iHeight <> 0 then aRowRec[iArrIdx].Height := iHeight * 20;

end;

if iArrIdx = 0 then

aRowRec[iArrIdx].OSet := (iCount - iLoop) *

(SizeOf(TRowRec) + 4)

else

aRowRec[iArrIdx].OSet := word(FUsedRows.Objects[i - 1]);

_WriteToken(XL_ROW,SizeOf(TRowRec));

BlockWrite(FFile,aRowRec[iArrIdx],SizeOf(TRowRec));

inc(iArrIdx);

end;

_SaveCells(aRowRec[0].RowIdx,aRowRec[high(aRowRec)].RowIdx);

SetLength(aRowRec,0);

iLoop := iLoop + (iCount - iLoop + 1);

if iLoop >= FUsedRows.Count - 1 then break;

end;

// Write WINDOW1 Record

BlockWrite(FFile,aWINDOW1,SizeOf(aWINDOW1));

end;

// =========================================================

// INTERNAL - Write out non-default column widths as

// set by ColumnWidth()

// =========================================================

procedure TExcelWorkSheet._SaveColWidths;

var i : integer;

iCol : byte;

iWidth : word;

begin

for i := 0 to FColWidths.Count - 1 do begin

iCol := StrToInt(FColWidths[i]);

iWidth := 256 * word(FColWidths.Objects[i]);

_WriteToken(XL_COLWIDTH,4);

Blockwrite(FFile,iCol,1);

Blockwrite(FFile,iWidth,2);

end;

// =======================================================

// INTERNAL Base Font Setting Method - Default and 1..3

// =======================================================

procedure TExcelWorkSheet._SetFont(AFontNum : byte;

const AFontName : string;

AFontSize : byte;

AFontStyle : TFontStyles;

AFontColor : word);

var sKey : string;

iAttr : integer;

begin

iAttr := 0;

if fsBold in AFontStyle then iAttr := iAttr or 1;

if fsItalic in AFontStyle then iAttr := iAttr or 2;

if fsUnderline in AFontStyle then iAttr := iAttr or 4;

if fsStrikeOut in AFontStyle then iAttr := iAttr or 8;

sKey := trim(AFontName) + '|' + IntToStr(AFontSize) +

'|' + IntToStr(iAttr);

FFontTable[AFontNum] := sKey;

FFontTable.Objects[AFontNum] := TObject(AFontColor);

end;

// =======================================================

// INTERNAL Base Font Get Info Method - Default and 1..3

// =======================================================

function TExcelWorkSheet._GetFont(AFontNum : byte) : TExcelFont;

var rResult : TExcelFont;

sKey : string;

iStyle : integer;

begin

rResult.FontStyle := [];

if AFontNum > 3 then AFontNum := 3;

sKey := FFontTable[AFontNum];

rResult.FontName := copy(skey,1,pos('|',sKey) - 1);

sKey := copy(sKey,pos('|',skey) + 1,2096);

rResult.FontSize := StrToInt(copy(sKey,1,pos('|',sKey) - 1));

iStyle := StrToInt(copy(sKey,pos('|',skey) + 1,2096));

rResult.FontColor := integer(FFontTable.Objects[AFontNum]);

if iStyle and 1 = 1 then include(rResult.FontStyle,fsBold);

if iStyle and 2 = 2 then include(rResult.FontStyle,fsItalic);

if iStyle and 4 = 4 then include(rResult.FontStyle,fsUnderline);

if iStyle and 8 = 8 then include(rResult.FontStyle,fsStrikeOut);

Result := rResult;

end;

// =====================================

// PUBLIC - Font Setting Methods

// =====================================

procedure TExcelWorkSheet.SetFont_Default(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

begin

_SetFont(XL_FONT_DEFAULT,AFontName,AFontSize,AFontStyle,AFontColor);

end;

procedure TExcelWorkSheet.SetFont_1(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

begin

_SetFont(XL_FONT_1,AFontName,AFontSize,AFontStyle,AFontColor);

end;

procedure TExcelWorkSheet.SetFont_2(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

begin

_SetFont(XL_FONT_2,AFontName,AFontSize,AFontStyle,AFontColor);

end;

procedure TExcelWorkSheet.SetFont_3(const AFontName : string;

AFontSize : byte = 10;

AFontStyle : TFontStyles = [];

AFontColor : word = 0);

begin

_SetFont(XL_FONT_3,AFontName,AFontSize,AFontStyle,AFontColor);

end;

// ======================================

// PUBLIC - Font Get Information Methods

// ======================================

function TExcelWorkSheet.GetFont_Default : TExcelFont;

begin

Result := _GetFont(XL_FONT_DEFAULT);

end;

function TExcelWorkSheet.GetFont_1 : TExcelFont;

begin

Result := _GetFont(XL_FONT_1);

end;

function TExcelWorkSheet.GetFont_2 : TExcelFont;

begin

Result := _GetFont(XL_FONT_2);

end;

function TExcelWorkSheet.GetFont_3 : TExcelFont;

begin

Result := _GetFont(XL_FONT_3);

end;

// =====================================

// Set a single column width

// =====================================

procedure TExcelWorkSheet.ColumnWidth(ACol : byte; AWidth : word);

var sKey : string;

iIdx : integer;

begin

sKey := IntToStr(ACol);

iIdx := FColWidths.IndexOf(sKey);

if AWidth > 255 then AWidth := 255;

if iIdx <> -1 then

FColWidths.Objects[iIdx] := TObject(AWidth)

else

FColWidths.AddObject(sKey,TObject(AWidth));

end;

// ============================

// Set a single row height

// ============================

procedure TExcelWorkSheet.RowHeight(ARow : word; AHeight : byte);

var sKey : string;

iIdx : integer;

begin

sKey := IntToStr(ARow);

iIdx := FRowHeights.IndexOf(sKey);

if iIdx <> -1 then

FRowHeights.Objects[iIdx] := TObject(AHeight)

else

FRowHeights.AddObject(sKey,TObject(AHeight));

end;

// =================================================

// Get a cell info object

// NOTE : A reference to the object is returned.

// No need for user to FREE the object

// =================================================

function TExcelWorkSheet.GetCell(ACol,ARow :word) : TExcelCell;

var oResult : TExcelCell;

sKey : string;

iIndex : integer;

begin

sKey := IntToHex(ARow,4) + IntToHex(ACol,4);

// Existing ?

if FCells.Find(sKey,iIndex) then

oResult := TExcelCell(FCells.Objects[iIndex])

else

oResult := nil;

Result := oResult;

end;

// ====================================================

// Add or replace a cell in the worksheet

// NOTE : A reference to the object is returned.

// No need for user to FREE the object

// ====================================================

function TExcelWorkSheet.NewCell(ACol,ARow :word) : TExcelCell;

var oResult : TExcelCell;

sKey : string;

iIndex : integer;

begin

oResult := TExcelCell.Create;

oResult.FRow := ARow;

oResult.FCol := ACol;

if ACol > 255 then oResult.FCol := 255;

sKey := IntToHex(ARow,4) + IntToHex(ACol,4);

// Existing ?

if FCells.Find(sKey,iIndex) then begin

TExcelCell(FCells.Objects[iIndex]).Free;

FCells.Objects[iIndex] := oResult;

end

else

FCells.AddObject(sKey,oResult);

Result := oResult;

end;

// =========================================

// Blanks out a cell in the worksheet

// =========================================

procedure TExcelWorkSheet.BlankCell(ACol,ARow :word);

var sKey : string;

iIndex : integer;

begin

sKey := IntToHex(ARow,4) + IntToHex(ACol,4);

// Existing ?

if FCells.Find(sKey,iIndex) then begin

TExcelCell(FCells.Objects[iIndex]).Free;

FCells.Delete(iIndex);

end;

// ===========================================

// Procedural way to add or change a cell

// ===========================================

procedure TExcelWorkSheet.SetCell(ACol,ARow : word;

ADataType : TExcelDataType;

AData : Olevariant;

AFontIndex : byte = 0;

AFormatString : string = 'General';

AAlign : TExcelCellAlign = xalGeneral;

AHasPattern : boolean = false;

ABorderStyle : TExcelBorders = []);

var oCell : TExcelCell;

sKey : string;

iIndex : integer;

begin

oCell := TExcelCell.Create;

oCell.FRow := ARow;

oCell.FCol := ACol;

if ACol > 255 then ACol := 255;

oCell.DataType := ADataType;

oCell.Data := AData;

oCell.FontIndex := AFontIndex;

if AFontIndex > 3 then oCell.FontIndex := 3;

oCell.FormatString := AFormatString;

oCell.Align := AAlign;

oCell.HasPattern := AHasPattern;

oCell.BorderStyle := ABorderStyle;

sKey := IntToHex(ARow,4) + IntToHex(ACol,4);

// Existing ?

if FCells.Find(sKey,iIndex) then begin

TExcelCell(FCells.Objects[iIndex]).Free;

FCells.Objects[iIndex] := oCell;

end

else

FCells.AddObject(sKey,oCell);

end;

// ====================================

// Save Worksheet as an XLS file

// ====================================

procedure TExcelWorkSheet.SaveToFile(const AFileName : string);

var aWord : array [0..1] of word;

begin

AssignFile(FFile,ChangeFileExt(AFileName,'.xls'));

Rewrite(FFile,1);

// BOF

_WriteToken(XL_BOF,4);

aWord[0] := 0;

aWord[1] := XL_DOCUMENT;

Blockwrite(FFile,aWord,SizeOf(aWord));

// FONT

_SaveFontTable;

// COLWIDTH

_SaveColWidths;

// COLFORMATS

_SaveFormats;

// DIMENSIONS

_SaveDimensions;

// CELLS

if FRowHeights.Count > 0 then

_SaveRowBlocks // Slower

else

_SaveCells(0,$FFFF); // Faster

// EOF

_WriteToken(XL_EOF,0);

CloseFile(FFile);

end;

end.