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.