|
|
Posted on
2007-06-13 16:25
OldHawk
阅读( 862)
评论()
编辑
收藏
举报
This Class allows you to create an Excel Worksheet in much the
same way as you create a TStringGrid. ie. Cell[Column,Row].
 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;
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;
end;
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;
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;
end;
end;
end;
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;
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;
end;
inc(ALast);
FUsedRows.Objects[AListIdx] := TObject(iDataSize);
end;
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,iCol,1);
Blockwrite(FFile,iWidth,2);
end;
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;
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.
|
