{ SemaphorGrid.pas ------------------- Lazarus LCL Component First Release: January 2005 Author: Salvatore Coppola - Calabria (Italy) ***************************************************************************** See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** } {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, LazUTF8, 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 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 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 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 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 {$R semaphorgridsicon.res} 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<i then RowCount:=RowCount+1; if ColCount<j+1 then ColCount:=j+1; Rows[i-1]:=riga; end; end else begin RowCount:=FixedRows+1; ColCount:=FixedCols+1; strFirst:=''; strtmp:=''; for i:=0 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<i+1 then RowCount:=RowCount+1; if ColCount<j+1 then ColCount:=j+1; Rows[i]:=riga; end end; riga.Free; if autoadjust then AutoAdjustColumns;//all cols, also hidden if strFirst<>'' then begin ExWidths.Clear; while pos(CHSEP+'j',strFirst)<>0 do begin Delete(strFirst,1,2);//delete CHSEP+'j'; strj:=copy(strFirst,1,pos(CHSEP,strFirst)-1); ColWidths[StrToInt(strj)]:=WidthZero;//GridLineWidth; ExWidths.Add('j'+strj); Delete(strFirst,1,length(strj+CHSEP)); if pos(CHSEP,strFirst)<>0 then begin strj:=copy(strFirst,1,pos(CHSEP,strFirst)-1); Delete(strFirst,1,pos(CHSEP,strFirst)-1); end else strj:=strFirst; ExWidths.Add(strj); end; strFirst:=''; end; end; procedure TSemaphorGrid.SaveBase(tabella:TStringList; addMarker:boolean); var riga:TStringList; strtmp:string; i,j:integer; begin riga:=TStringList.Create; if addMarker then begin strtmp:=SemaphorMarker+CHSEP+IntToStr(FixedCols)+CHSEP+IntToStr(FixedRows);//store n� fixed cols and rows for j:=0 to ExWidths.Count-1 do //store the widths of hided cols if any (and then the hided cols) strtmp:=strtmp+CHSEP+ExWidths.Strings[j]; tabella.Add(strtmp); end; for i:=0 to RowCount-1 do begin riga.Assign(Rows[i]); strtmp:=riga.Strings[0]; for j:=1 to riga.Count-1 do strtmp:=strtmp+CHSEP+riga.Strings[j]; tabella.Add(strtmp); end; riga.Free; end; procedure TSemaphorGrid.LoadFromFileG(FileName:string;autoadjust:boolean); var tabella:TStringList; begin tabella:=TStringList.Create; tabella.LoadFromFile(UTF8ToSys(Filename)); LoadBase(tabella,autoadjust); tabella.Free; end; { FileName: file to store data } procedure TSemaphorGrid.SaveToFileG(FileName:String;addMarker:boolean); var tabella:TStringList; begin tabella:=TStringList.Create; SaveBase(tabella,addMarker); tabella.SaveToFile(UTF8ToSys(FileName)); tabella.Free; end; procedure TSemaphorGrid.LoadFromString(StringName:string; autoadjust:boolean); var tabella:TStringList; begin tabella:=TStringList.Create; tabella.Text:=StringName; LoadBase(tabella,autoadjust); tabella.Free; end; procedure TSemaphorGrid.SaveToString(var StringName:String; addMarker:boolean); var tabella:TStringList; begin tabella:=TStringList.Create; SaveBase(tabella,addMarker); StringName:=tabella.Text; tabella.Free; end; procedure TSemaphorGrid.AssignG(SG: TSemaphorGrid; autoadjust:boolean); var strtmp:string; begin SG.SaveToString(strtmp,true); LoadFromString(strtmp, autoadjust); end; procedure TSemaphorGrid.AssignToG(SG: TSemaphorGrid; autoadjust:boolean); var strtmp:string; begin SaveToString(strtmp,true); SG.LoadFromString(strtmp, autoadjust); end; procedure TSemaphorGrid.AutoWidth; var j,Wtmp:integer; begin Wtmp:=0; if BorderStyle=bsSingle then {$IFdef MSWindows} Wtmp:=Wtmp+2*GetSystemMetrics(SM_CXFIXEDFRAME); {$ELSE} Wtmp:=Wtmp+2*1;//GetSystemMetrics(SM_CXFIXEDFRAME); {$ENDIF} for j:=0 to ColCount-1 do Wtmp:=Wtmp+GridLineWidth+ColWidths[j]; Wtmp:=Wtmp-2*GridLineWidth; if ScrollBarIsVisible(SB_Vert) then begin Wtmp:=Wtmp+GetSystemMetrics(SM_CXVSCROLL);//+GetSystemMetrics(SM_CXEDGE); end; Width:=Wtmp; end; procedure TSemaphorGrid.AutoHeight; var i,Htmp:integer; begin Htmp:=0; if BorderStyle=bsSingle then {$IFdef MSWindows} Htmp:=Htmp+2*GetSystemMetrics(SM_CYFIXEDFRAME); {$ELSE} Htmp:=Htmp+2*1;//GetSystemMetrics(SM_CYFIXEDFRAME); {$ENDIF} for i:=0 to RowCount-1 do Htmp:=Htmp+GridLineWidth+RowHeights[i]; Htmp:=Htmp-2*GridLineWidth; if ScrollBarIsVisible(SB_Horz) then begin Htmp:=Htmp+GetSystemMetrics(SM_CYVSCROLL); end; Height:=Htmp; end; procedure TSemaphorGrid.AutoFit; begin AutoWidth; AutoHeight; if not ScrollBarIsVisible(SB_Vert) then AutoWidth; if not ScrollBarIsVisible(SB_Horz) then AutoHeight; end; { FileName: file to export data; SelfExt: if true SemaphorGrid change the file extension to xls compatible with MS Excel and maybe other similar, and if there is not extension SemaphorGrid append xls extension to FileName } procedure TSemaphorGrid.ExportToExcel(FileName:string;SelfExt:boolean); var CHSEPOld:Char; FileNameXLS:string; begin CHSEPOld:=CHSEP; CHSEP:=#9;//tab FileNameXLS:=FileName; if (SelfExt)and(UpperCase(ExtractFileExt(FileNameXLS))<>'XLS') then begin Delete(FileNameXLS,Length(FileNameXLS)-2,3);//pos(CHSEP,strtmp)) if Pos('.',FileNameXLS)<>(Length(FileNameXLS)) then FileNameXLS:=FileNameXLS+'.xls' else FileNameXLS:=FileNameXLS+'xls'; end; SaveToFileG(FileNameXLS,false); CHSEP:=CHSEPOld end; function TSemaphorGrid.DoCompareCells(Acol, ARow, Bcol, BRow: Integer): Integer; var S1,S2: String; V1,V2: Extended; begin case FSortType of tsAlphabetic: begin S1 := Cells[ACol,ARow]; S2 := Cells[BCol,BRow]; if S1>S2 then Result := 1 else if S1<S2 then Result := -1 else result := 0; end; tsNumeric, tsDate: begin if fSortType = tsNumeric then begin V1 := StrToFloatDef(Cells[ACol,ARow], 0.0); V2 := StrToFloatDef(Cells[BCol,BRow], 0.0); end else begin V1 := StrToDate(Cells[ACol,ARow]); V2 := StrToDate(Cells[BCol,BRow]); end; if V1>V2 then Result := 1 else if V1<V2 then Result := -1 else result := 0; end; end; if FSortDirection=sdDescending then begin if Result<0 then result:=1 else if result>0 then result:=-1; end; if assigned(OnCompareCells) then OnCompareCells(Self, ACol,ARow,BCol,BRow, Result); end; procedure TSemaphorGrid.DeleteColumn(j:integer); begin DeleteColRow(true,j); end; procedure TSemaphorGrid.DeleteRow(i:integer); begin DeleteColRow(false,i); end; procedure TSemaphorGrid.SortFromColumn(j:integer; TS:TTypeSort; SD:TDirection; autoadjust:boolean); function AutomaticSortType: TTypeSort; var i: Integer; begin // returns the sort type of a omogeneus column j // for non omogeneus, Alphabetical is assumed Result:=tsNumeric; for i:=FixedRows to RowCount-1 do if Cells[j,i]<>'' then try StrToFloat(Cells[j,i]); except Result:=tsDate; break; end; if Result=tsNumeric then exit; for i:=FixedRows to RowCount-1 do if Cells[j,i]<>'' then try StrToDate(Cells[j,i]); except Result:=tsAlphabetic; break; end; end; begin if Ts=tsAutomatic then FSortType := AutomaticSortType else FSortType := Ts; FSortDirection := SD; BeginUpdate; SortColRow(True, J); if autoadjust then AutoAdjustColumns; EndUpdate(true); end; procedure TSemaphorGrid.HideCol(j:integer); var strj:string; begin if j<ColCount then begin strj:='j'+IntToStr(j); if ExWidths.IndexOf(strj)<>-1 then begin exit end else begin ExWidths.Add(strj); ExWidths.Add(IntToStr(ColWidths[j])); end; ColWidths[j]:=WidthZero; end; end; procedure TSemaphorGrid.ShowCol(j:integer); var strj:string; index:integer; begin if j<ColCount then begin strj:='j'+IntToStr(j); index:=ExWidths.IndexOf(strj); if index<>-1 then begin ColWidths[j]:=StrToInt(ExWidths.Strings[index+1]); ExWidths.Delete(index+1); ExWidths.Delete(index); end else exit; end; end; procedure TSemaphorGrid.ShowAllCols; var j:integer; strj:string; begin while ExWidths.Count>0 do begin strj:=ExWidths.Strings[0]; Delete(strj,1,1); j:=StrToInt(strj); ColWidths[j]:=StrToInt(ExWidths.Strings[1]); ExWidths.Delete(1); ExWidths.Delete(0); end; (* as different solution for j:=0 to ColCount-1 do ShowCol(j); *) end; function TSemaphorGrid.Duplicate(var SG:TSemaphorGrid):Boolean; var i,j:integer; // da migliorare duptmp:Boolean; begin duptmp:=True; try SG.ColCount:=ColCount; SG.RowCount:=RowCount; for i:=0 to RowCount-1 do for j:=0 to ColCount-1 do SG.Cells[j,i]:=Cells[j,i]; except duptmp:=False; SG.Clear(false); end; Result:=duptmp end; procedure TSemaphorGrid.ClearColRow(isColumn:boolean; i:integer); var j:integer; begin if isColumn then for j:=0 to RowCount-1 do Cells[i,j]:='' else for j:=0 to ColCount-1 do Cells[j,i]:='' end; procedure TSemaphorGrid.Clear(OnlyValue:boolean); var i:integer; begin for i:= 0 to RowCount-1 do ClearColRow(false,i); if not OnlyValue then begin RowCount:=FixedRows+1; ColCount:=FixedCols+1 end end; procedure TSemaphorGrid.SetAlignment(Value: TAlignment); begin If FAlignment <> Value then begin FAlignment := Value; Invalidate; end; end; procedure TSemaphorGrid.SetCHSEP(Value : Char); begin FCHSEP:=Value; end; procedure TSemaphorGrid.SetSemaphor(Value : boolean); begin FSemaphor:=Value; Invalidate; end; procedure TSemaphorGrid.SetStringRed(Value : string); begin FStringRed:=Value; Invalidate; end; procedure TSemaphorGrid.SetStringYellow(Value : string); begin FStringYellow:=Value; Invalidate; end; procedure TSemaphorGrid.SetStringGreen(Value : string); begin FStringGreen:=Value; Invalidate; end; procedure TSemaphorGrid.SetSemaphorShape(Value : TSemaphorShape); begin FSemaphorShape:=Value; Invalidate; end; procedure TSemaphorGrid.SetSemaphorCaseSensitive(Value : boolean); begin FSemaphorCaseSensitive:=Value; invalidate; end; procedure TSemaphorGrid.SetSemaphorOnlyFloat(Value : boolean); begin FSemaphorOnlyFloat:=Value; end; constructor TSemaphorGrid.Create(AOwner: TComponent); begin inherited Create(AOwner); FCHSEP:=#255; Semaphor:=False; StringRed:='no'; StringYellow:='maybe'; StringGreen:='yes'; SemaphorShape:=ssDisk; SemaphorCaseSensitive:=False; SemaphorOnlyFloat:=False; Alignment:=taLeftJustify; WidthZero:=GridLineWidth; ExWidths:=TStringList.Create; end; destructor TSemaphorGrid.Destroy; begin ExWidths.Free; inherited Destroy end; procedure Register; begin RegisterComponents('Additional',[TSemaphorGrid]); end; end.