{ SemaphorGrid.pas ------------------- Lazarus LCL Component First Release: January 2005 Author: Salvatore Coppola - Calabria (Italy) ***************************************************************************** * * * See the file COPYING.modifiedLGPL, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** } {ABSTRACT SEMAFORO (Semaphor) in Italian Language means Traffic Lights. If Semaphor is set to true,when TSemaphorGrid detect in a non Fixed Cells a string like StringGreen or StringYellow or StringRed, it show a colored sign in the corrispondent cells (shape choosed in SemaphorShape). It can be Case Sensitive (SemaphorCaseSensitive). If Semaphor is false, nothing happen. SemaphorGrid is able to store and restore data by indipendent method LoadFromFileG and SaveToFileG wich manage also accented chars in data and similar. Data are separeted by CHSEP. LoadFromFileG has autoadjust wich allow SemaphorGrid to AutosizeColumns. SemaphorGrid, at the moment, is unable to store setting grid (only Column Hidden and in general ColWidth). With the method ExportToExcel, SemaphorGrid is able set CHSEP so that the file generated is MS Excel compatible. SemaphorGrid is also able to sort a column wrapping all the Grid with the method SortFromColumn with indipendent sorting method (maybe it should be better to use onCompareCell) That's all Enjoy! Salvatore Date: 15-Jan-2005 - Changed SortFromColumn: now it use SortColRow, OnCompareCells and DoCompareChange (from Jesus Rejes A.); - Removed SortDate, SortNumeric, uses Windows (now useless) - Correct some repainting problems (from Jesus Rejes A.) - removed ReDrawGrid (now useless) Date: 03-Apr-2005 - Some sources cleaning - introduced System Metrics in AutoWidth and AutoHeight (keep in count scrollbars); Date: 04-May-2005 - set default CHARSEP to #255 knowed bug: re-sorting a column that have two or more cells equal, the corrispondent rows are swapped, so there are more than one grid sorted by the same column. } unit SemaphorGrids; {$mode objfpc} {$H+} interface uses Classes, SysUtils, LResources, LCLProc, LCLIntf, LCLType, Forms, Controls, Graphics, Dialogs, Grids; const SemaphorMarker='S_M_0_1'; type TSheetType=(stLandScape,stPortrait); TSemaphorShape=(ssTopBar,ssBottomBar,ssLeftBar,ssRigthBar, ssTopLeftSquare,ssTopRigthSquare,ssBottomLeftSquare, ssBottomRigth,ssDisk); TDirection = (sdDescending, sdAscending); TTypeSort = (tsAlphabetic, tsDate, tsNumeric, tsAutomatic); type { TSemaphorGrid } TSemaphorGrid = class(TStringGrid) private { Private declarations } WidthZero:integer; ExWidths: TStringList; FAlignment: TAlignment; FCHSEP : Char; FSemaphor : boolean; FStringRed : string; FStringYellow : string; FStringGreen : string; FSemaphorShape : TSemaphorShape; FSemaphorCaseSensitive : boolean; FSemaphorOnlyFloat : boolean; FSortDirection: TDirection; FSortType: TTypeSort; procedure SetAlignment(Value: TAlignment); procedure SetCHSEP(Value : Char); procedure SetSemaphor(Value : boolean); procedure SetStringRed(Value : string); procedure SetStringYellow(Value : string); procedure SetStringGreen(Value : string); procedure SetSemaphorShape(Value : TSemaphorShape); procedure SetSemaphorCaseSensitive(Value : boolean); procedure SetSemaphorOnlyFloat(Value : boolean); protected { Protected declarations } procedure DrawCell(aCol,aRow: Integer; aRect: TRect; aState:TGridDrawState); override; function DoCompareCells(Acol,ARow,Bcol,BRow: Integer): Integer; override; procedure KeyPress(var Key: Char); override; procedure LoadBase(tabella:TStringList; autoadjust:boolean); procedure SaveBase(tabella:TStringList; addMarker:boolean); procedure LoadFromString(StringName:string; autoadjust:boolean); public { Public declarations } procedure LoadFromFileG(FileName:string; autoadjust:boolean); procedure SaveToFileG(FileName:String;addMarker:boolean); procedure SaveToString(var StringName:String; addMarker:boolean); procedure AssignG(SG: TSemaphorGrid; autoadjust:boolean); procedure AssignToG(SG: TSemaphorGrid; autoadjust:boolean); procedure AutoWidth; procedure AutoHeight; procedure AutoFit; procedure ExportToExcel(FileName:string;SelfExt:boolean); procedure DeleteColumn(j:integer); procedure DeleteRow(i:integer); procedure SortFromColumn(j:integer; TS:TTypeSort; SD:TDirection; autoadjust:boolean); procedure HideCol(j:integer); procedure ShowCol(j:integer); procedure ShowAllCols; function Duplicate(var SG:TSemaphorGrid):boolean; procedure ClearColRow(isColumn:boolean; i:integer); procedure Clear(OnlyValue:boolean); constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published declarations } property Constraints; property Alignment: TAlignment read FAlignment write SetAlignment; property CHSEP : Char read FCHSEP write SetCHSEP default #255; property Semaphor : boolean read FSemaphor write SetSemaphor; property StringRed : string read FStringRed write SetStringRed; property StringYellow : string read FStringYellow write SetStringYellow; property StringGreen : string read FStringGreen write SetStringGreen; property SemaphorShape : TSemaphorShape read FSemaphorShape write SetSemaphorShape; property SemaphorCaseSensitive : boolean read FSemaphorCaseSensitive write SetSemaphorCaseSensitive; property SemaphorOnlyFloat : boolean read FSemaphorOnlyFloat write SetSemaphorOnlyFloat; end; procedure Register; implementation procedure TSemaphorGrid.DrawCell(aCol,aRow: Integer; aRect: TRect; aState:TGridDrawState); const dr=4; var Rect:TRect; MyStyle:TTextStyle; begin PrepareCanvas(aCol,aRow,aState); Canvas.FillRect(aRect); DrawCellGrid(aCol,aRow,aRect,astate); MyStyle:=Canvas.TextStyle; MyStyle.Alignment:=Alignment; //text space aRect.Left:=aRect.Left+dr; aRect.Right:=aRect.Right-dr; aRect.Bottom:=aRect.Bottom-dr; aRect.Top:=aRect.Top+dr; Canvas.TextRect(aRect,aRect.Left, aRect.Top, Cells[aCol,aRow],MyStyle); if not Semaphor then exit; Rect:=CellRect(aCol,aRow); case SemaphorShape of ssTopBar: Rect.Bottom:=Rect.Top+dr-1; ssBottomBar:Rect.Top:=Rect.Bottom-dr; ssLeftBar:Rect.Right:=rect.Left+dr-1; ssRigthBar:Rect.Left:=rect.Right-dr; ssTopLeftSquare:begin Rect.Bottom:=Rect.Top+dr; Rect.Right:=Rect.Left+dr; end; ssTopRigthSquare:begin Rect.Bottom:=Rect.Top+dr; Rect.Left:=Rect.Right-dr-1; end; ssBottomLeftSquare:begin Rect.Top:=Rect.Bottom-dr-1; Rect.Right:=Rect.Left+dr; end; ssBottomRigth:begin Rect.Top:=Rect.Bottom-dr-1; Rect.Left:=Rect.Right-dr-1; end; ssDisk:begin Rect.Bottom:=Rect.Top+2*dr-1; Rect.Left:=Rect.Right-2*dr+1-1; end; end; case SemaphorCaseSensitive of false: if (UpperCase(Cells[aCol,aRow])=UpperCase(StringGreen))and((aCol>FixedCols-1)and(aRow>FixedRows-1)) then begin Canvas.Brush.Color:=clGreen; if not(SemaphorShape=ssDisk) then Canvas.Rectangle(Rect) else Canvas.Ellipse(Rect); end else if(UpperCase(Cells[aCol,aRow])=UpperCase(StringRed))and((aCol>FixedCols-1)and(aRow>FixedRows-1)) then begin Canvas.Brush.Color:=clRed; if not(SemaphorShape=ssDisk) then Canvas.Rectangle(Rect) else Canvas.Ellipse(Rect); end else if(UpperCase(Cells[aCol,aRow])=UpperCase(StringYellow))and((aCol>FixedCols-1)and(aRow>FixedRows-1)) then begin Canvas.Brush.Color:=clYellow; if not(SemaphorShape=ssDisk) then Canvas.Rectangle(Rect) else Canvas.Ellipse(Rect); end; true: if (Cells[aCol,aRow]=StringGreen)and((aCol>FixedCols-1)and(aRow>FixedRows-1)) then begin Canvas.Brush.Color:=clGreen; if not(SemaphorShape=ssDisk) then Canvas.Rectangle(Rect) else Canvas.Ellipse(Rect); end else if(Cells[aCol,aRow]=StringRed)and((aCol>FixedCols-1)and(aRow>FixedRows-1)) then begin Canvas.Brush.Color:=clRed; if not(SemaphorShape=ssDisk) then Canvas.Rectangle(Rect) else Canvas.Ellipse(Rect); end else if(Cells[aCol,aRow]=StringYellow)and((aCol>FixedCols-1)and(aRow>FixedRows-1)) then begin Canvas.Brush.Color:=clYellow; if not(SemaphorShape=ssDisk) then Canvas.Rectangle(Rect) else Canvas.Ellipse(Rect); end; end; end; procedure TSemaphorGrid.KeyPress(var Key: Char); var strOld:string; valore:double; begin inherited KeyPress(Key); if (SemaphorOnlyFloat)and(goEditing in Options) then begin if (Key=',')or(Key='.') then Key:=DecimalSeparator; if (Key=' ')or(UpCase(Key)='E') then key:=#0; if Key='-' then begin strOld:=Cells[Col,Row]; if Pos(Key,strOld)=1 then delete(strOld,1,1) else strOld:=Key+strOld; Cells[Col,Row]:=strOld; Key:=#0; exit end; if not(Ord(Key)=VK_BACK) then begin if Cells[Col,Row]<>'' then begin strOld:=Cells[Col,Row]; try valore:=StrToFloat(strOld+Key) except Key:=#0; exit end end else begin strOld:=''; try valore:=StrToFloat(Cells[Col,Row]+Key) except Cells[Col,Row]:=strOld; Key:=#0 end; end end; end; end; procedure TSemaphorGrid.LoadBase(tabella:TStringList; autoadjust:boolean); var riga:TStringList; strtmp,strFirst:string; i,j:integer; strj:string; begin riga:=TStringList.Create; strFirst:=tabella.Strings[0]; RowCount:=FixedRows+2;//to prevent grid exception ColCount:=FixedCols+2; if pos(SemaphorMarker,strFirst)<>0 then begin Delete(strFirst,1,pos(CHSEP,strFirst));//delete marker+CHSEP j:=pos(CHSEP,strFirst)-1; FixedCols:=StrToInt(copy(strFirst,1,j)); //retrive FixedCols Delete(strFirst,1,j+1);//pos(CHSEP,strtmp));//delete FixedCols+CHSEP i:=pos(CHSEP,strFirst)-1; if i=-1 then //i.e. pos(CHSEP,strtmp)=0 i:=length(strFirst); FixedRows:=StrToInt(copy(strFirst,1,i));//retrive FixedCols Delete(strFirst,1,i); strtmp:=''; RowCount:=FixedRows+1; ColCount:=FixedCols+1; for i:=1 to tabella.Count-1 do begin //riga[0] gia usata per fixed rows and cols strtmp:=tabella.Strings[i]; riga.Clear; j:=0; while (strtmp<>'')or(pos(CHSEP,strtmp)<>0)do if pos(CHSEP,strtmp)<>0 then begin j:=j+1; riga.Add(copy(strtmp,1,pos(CHSEP,strtmp)-1)); Delete(strtmp,1,pos(CHSEP,strtmp)) end else begin riga.Add(strtmp); strtmp:='' end; if RowCount'')or(pos(CHSEP,strtmp)<>0)do if pos(CHSEP,strtmp)<>0 then begin j:=j+1; riga.Add(copy(strtmp,1,pos(CHSEP,strtmp)-1)); Delete(strtmp,1,pos(CHSEP,strtmp)) end else begin riga.Add(strtmp); strtmp:='' end; if RowCount