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.

本文转自 OldHawk 博客园博客，原文链接： http://www.cnblogs.com/taobataoma/archive/2007/06/13/782376.html ，如需转载请自行联系原作者

Freeform Excel Worksheet (No OLE or EXCEL required)

热门文章

最新文章

相关电子书