COMPOSANT GRILLE AVEC NOUVELLES PROPRIÉTÉS

unit TGrille;     // Composant Visuel Grille Hérité TStringGrid @ Guy Bidi 2008
interface
uses Windows,SysUtils,Classes,Controls,Grids,Types,Graphics,Forms,StdCtrls,
     Dialogs,ShellApi;
 Const Mess='  Propriété About : Auteur : © Guy Bidi - paounet@free.fr'+Chr(13)+Chr(13)+
      ' 1 - La Propriété Aide à True affiche l''Aide actuelle.'+Chr(13)+Chr(13)+
      ' 2 - La Propriété AlignText :'+Chr(13)+Chr(13)+
      '      Left       :   Aligne à Gauche le texte des  Cellules.'+Chr(13)+
      '      Center  :   Aligne au Centre le texte des Cellules.'+Chr(13)+
      '      Right    :   Aligne à Droite    le texte des Cellules.'+Chr(13)+Chr(13)+
      ' 3 - La Propriété Automatic :  Ajuste la Largeur et Hauteur de la Grille (True ).'+Chr(13)+Chr(13)+
      ' 4 - La Propriété FormatNumeric : '+Chr(13)+Chr(13)+
      '      En utilisant les symbôles de formatage tels que #, 0, . les cellules contenant des'+Chr(13)+
      '      nombres seront formatés à droite comme la fonction FormatFloat (''0.##'',Valeur).'+Chr(13)+Chr(13)+
      ' 5 - La Propriété CellColor: CellCor :  Couleur pour la Cellule choisie.'+Chr(13)+Chr(13)+
      '      IndexCol   : Index de Colonne   /   IndexRow : Index de Ligne.'+Chr(13)+
      '      Si IndexRow/IndexCol est vide alors toute la colonne/Ligne sera affichée '+Chr(13)+
      '      avec la couleur issue de CellColor.'+Chr(13)+Chr(13)+
      ' 6- Utilisation de la Fonction Publiée : ChangeCellColor(Acol,ARow:Integer)'+Chr(13)+Chr(13)+
      '       - Couleur de Cellule : CellColor.Color '+Chr(13)+Chr(13)+
      ' 7 - La Propriété Picture : Image BitMap sélectionnée pour la fonction CellBitMap'+Chr(13)+Chr(13)+
      ' 8- Utilisation de la Fonction Publique : CellBitMap(ACol,ARow:Integer)'+Chr(13)+Chr(13)+
      '          Grille1.CellBitMap(-1,-1) Toute la Grille est dessinée'+Chr(13)+
      '          Grille1.CellBitMap(2,3);   La Cellule(2,3) est dessinée'+Chr(13)+
      '          Grille1.CellBitMap(-1,2);  Toute la Ligne N° 2 est dessinée'+Chr(13)+
      '          Grille1.CellBitMap(2,-1);  Toute la Colonne N° 2 est dessinée';
type
  TCellColor = class(TPersistent)                     // Propriétés rajoutées à Grille
  private             { Déclarations privées }        // Variables Utilisées
  FColor:TColor;FCol:String;FRow:String;              // Couleur, Colonne, Ligne
  Procedure SetCol(Value:String);
  Procedure SetRow(Value:String);
  protected           { Déclarations protégées }
  public              { Déclarations publiques }
    Constructor Create(Owner:Tcomponent);
  published           { Déclarations publiées }
    Property Color:TColor Read FColor Write FColor;
    Property IndexCol:String Read FCol Write SetCol;
    Property IndexRow:String Read FRow Write SEtRow;
end;
type
  TAbout=String;                            // Propriété About rajoutée
  TAide=Boolean;                            // Propriété Aide sur le Composant
  TAlignText=(Left,Center,Right);           // Propriété Alignement du Texte
  TAuto=Boolean;                            // Ajuste la Grille Automatiquement
  TFormat=String;                           // Propriété Format pour Numérique
  Grille = class(TStringGrid)
  private             { Déclarations privées }        // Variables Utilisées
    FAbout:TAbout;FAide:TAide;FAlignText:TAlignText;Fauto:TAuto;FFormat:TFormat;
    FCellColor:TCellColor;FormAide:TForm;Memo:TMemo;FBitMap:TBitMap;
  protected           { Déclarations protégées }
   procedure DrawCell(ACol:Longint;ARow:Longint;Rectangle:TRect;State:TGridDrawState); override;
   procedure MemoDblClick(Sender:TObject);
   procedure SetBitMap(Value:TBitMap);
  public              { Déclarations publiques }
    Constructor Create(Owner:Tcomponent);override;
    destructor Destroy;Override;
  published           { Déclarations publiées }
    Property About:TAbout read FAbout;
    Property Aide:TAide read FAide Write FAide;
    Property AlignText:TAlignText read FAlignText Write FAlignText;
    Property Automatic:TAuto read FAuto Write FAuto;
    Property FormatNumeric:TFormat Read FFormat Write FFormat;
    Property CellColor:TCellColor Read FCellColor Write FCellColor;
    Property CellPicture:TBitMap Read FBitMap Write SetBitMap;
    Procedure ChangeColorCell(ACol,ARow:Integer);
    Procedure CellBitMap(ACol,ARow:Integer);
end;
procedure Register;
implementation
Procedure Grille.MemoDblClick(Sender:TObject);
Begin
  FormAide.ModalResult:=mrOk;
End;
Constructor TCellColor.Create(Owner:TComponent);
Begin
    // Rien Ici
End;
procedure Grille.SetBitMap(Value:TBitMap);
begin
  If Value<>Nil Then FBitMap.Assign(Value);
end;
Constructor Grille.Create(Owner:TComponent);
Begin
  Inherited Create(Owner);FixedCols:=0;FixedRows:=0;FAbout:='© Guy Bidi - 2008';
  Font.Name:= 'Comic Sans MS';ScrollBars:=ssNone;FAlignText:=Center;
  FAuto:=True;FAide:=False;Font.Style:=[fsBold];FFormat:='';Color:=clMoneyGreen;
  If Owner Is TForm Then With TForm(Owner)Do Position:=poScreenCenter;
  FormAide:=TForm.CreateNew(Application);With FormAide Do Begin Left:=0;Top:=0;
  AutoSize:=True;BorderIcons:=[];BorderStyle:=bsDialog;ClientHeight:=577;
  Caption:='Les Nouvelles Propriétés du Composant Grille © Guy Bidi - 2008';
  ClientWidth:=561;Color:=clBtnFace;Font.Charset:=DEFAULT_CHARSET;Font.Style:=[];
  Font.Color:=clWindowText;Font.Height:=-13;Font.Name:='Century Gothic';
  OldCreateOrder:=False;Position:=poScreenCenter;PixelsPerInch:=120;End;
  Memo:=TMemo.Create(Owner);With Memo Do Begin Parent:=FormAide;Left:=0;Top:=0;
  Width:=567;Height:=608;Hint:='Double-Cliquer pour sortir';Color:=clSkyBlue;
  Font.Charset:=DEFAULT_CHARSET;Font.Color:=clBlack;Font.Height:=-13;
  Font.Name:='Century Gothic';Font.Style:=[fsBold];ParentFont:=False;
  ParentShowHint:=False;ShowHint:=True;Lines.Text:=Mess;
  WantReturns:=True;OnDblClick:=MemoDblClick;End;
  FCellColor:=TCellColor.Create(Self);With FCellColor Do Begin
    FColor:=Color;FCol:='';FRow:='';End;
  FBitMap:=TBitMap.Create;
End;
Procedure TCellColor.SetCol(Value:String);
Begin
  If Not(Ord(Copy(Value,1,1))) In [49..59] Then Value:='';FCol:=Value;
End;
Procedure TCellColor.SetRow(Value:String);
Begin
  If Not(Ord(Copy(Value,1,1))) In [49..59] Then Value:='';FRow:=Value;
End;
Procedure Grille.DrawCell(ACol,ARow:Integer;Rectangle:TRect;State:TGridDrawState);
Var Valeur:Real;Code,i,j:Integer;
Begin                            // Surchage OnDrawCell de la Grille
  Val(Trim(Cells[ACol,ARow]),Valeur,Code);
  If (FFormat<>'') And (Code=0) And (Trim(Cells[ACol,ARow])<>'') Then
      DrawText(Canvas.Handle,PWideChar(FormatFloat(FFormat,Valeur)),
      -1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
   Else
      If FAlignText=Center then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
      -1,Rectangle,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
      Else If FAlignText=Right then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
      -1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
      Else DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
      -1,Rectangle,DT_LEFT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE);
  If FAuto=True then Begin
    Width:=ColCount*DefaultColWidth+(ColCount+1)*GridLineWidth;
    Height:=RowCount*DefaultRowHeight+(RowCount+1)*GridLineWidth;End;
  If FAide then Begin FAide:=False;FormAide.ShowModal;End;
  If (FCellColor.FCol='') And (FCellColor.FRow='') Then Exit;
  If (FCellColor.FCol<>'') And (FCellColor.FRow<>'') And
    (StrToInt(FCellColor.FRow)<RowCount) And
    (StrToInt(FCellColor.FCol)<ColCount) Then Begin
    ChangeColorCell(StrToInt(FCellColor.Fcol),StrToInt(FCellColor.FRow));Exit;End;
  If FCellColor.FCol='' Then Begin
    If StrToInt(FCellColor.FRow)<RowCount Then Begin
      For i := 0 to ColCount - 1 do For j := 0 to RowCount-1 do Begin
        ChangeColorCell(i,StrToInt(FCellColor.FRow));End;Exit;End
    Else Begin MessageDlg('Valeur de Ligne trop grande',mtInformation,[mbOk],0,mbOk);
      FCellColor.FRow:='';Exit;End;End
  Else If FCellColor.FRow='' Then Begin
      If StrToInt(FCellColor.FCol)<ColCount Then Begin
        For i := 0 to ColCount - 1 do For j := 0 to RowCount-1 do Begin
          ChangeColorCell(StrToInt(FCellColor.FCol),j);End;Exit; End
      Else Begin MessageDlg('Valeur de Colonne trop grande',mtInformation,[mbOk],0,mbOk);
        FCellColor.FCol:='';Exit;End;End;
  FBitMap:=TBitMap.Create;FBitMap:=Nil;
End;
Procedure Grille.CellBitMap(ACol,ARow:Integer); // Procedure Publique CellBitMap
Var Rect,Rect1:TRect;
Begin
  If ACol<0 Then                            // Pas de Colonne
    If ARow<0 Then Begin                    // Toute la Grille est dessinée...
      Rect:=BoundsRect;Rect.Right:=Rect.Right-Rect.Left;
      Rect.Bottom:=Rect.Bottom-Rect.Top;Rect.Left:=0;Rect.Top:=0;End
    Else                                   // Toute une Colonne est dessinée
      If ARow>RowCount-1 Then Begin MessageDlg('Valeur de Ligne trop grande',
        mtInformation,[mbOk],0,mbOk);Exit;End
      Else Begin                           // Toute une Ligne est dessinée
        Rect:=CellRect(0,ARow);Rect1:=CellRect(ColCount-1,ARow);
        Rect.Right:=Rect1.Right;Rect.Bottom:=Rect1.Bottom;End
  Else If ARow<0 then
    If ACol>ColCount-1 Then Begin MessageDlg('Valeur de Ligne erronée',
      mtInformation,[mbOk],0,mbOk);Exit;End
    Else Begin                             // Toute une Colonne est dessinée
      Rect:=CellRect(ACol,0);Rect1:=CellRect(ACol,RowCount-1);
      Rect.Right:=Rect1.Right;Rect.Bottom:=Rect1.Bottom;End
  Else If (ACol>ColCount-1) Or (ARow>RowCount-1) Then Begin
    MessageDlg('Valeur de Colonne/Ligne erronée',mtInformation,[mbOk],0,mbOk);
  Exit;End Else Rect:=CellRect(ACol,ARow); // Une seule Cellule est dessinée
  Canvas.StretchDraw(Rect,CellPicture);    // Affiche le dessin dans Cellule(s)
End;
Procedure Grille.ChangeColorCell(ACol,ARow:Integer); // Changement de Couleur/Cellule
Var Valeur:Real;Code:Integer;Rectangle:TRect;
Begin
  Canvas.Brush.Color:=FCellColor.FColor;
  Rectangle:=CellRect(ACol,ARow);
  Canvas.TextRect(Rectangle,Rectangle.Left,Rectangle.Top,'');
  If Cells[ACol,ARow]<>'' then Begin
    Val(Trim(Cells[ACol,ARow]),Valeur,Code);
  If (FFormat<>'') And (Code=0) And (Trim(Cells[ACol,ARow])<>'') Then
      DrawText(Canvas.Handle,PWideChar(FormatFloat(FFormat,Valeur)),
      -1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
   Else
      If FAlignText=Center then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
      -1,Rectangle,DT_CENTER or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
      Else If FAlignText=Right then DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
      -1,Rectangle,DT_RIGHT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE)
      Else DrawText(Canvas.Handle,PWideChar(Cells[ACol,ARow]),
      -1,Rectangle,DT_LEFT or DT_NOPREFIX or DT_VCENTER or DT_SINGLELINE);
  End;
end;
destructor Grille.Destroy;             // Destruction du Composant
begin
  inherited Destroy;
end;
procedure Register;                   // Enregistre le Composant Grille
begin
  RegisterComponents('Guy Bidi',[Grille]);
end;
end.

Test du Composant Grille = Fichier TTest.pas (Test.dproj)
unit TTest;
interface
uses Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
     Dialogs,Grids,TGrille,StdCtrls,Buttons,Types;
type
  TFormGrille = class(TForm)Cellules:TSpeedButton;
    CellBitMapT: TSpeedButton;          
    CellBitMapC: TSpeedButton;
    CellBitMapCol: TSpeedButton;
    CellBitMapRow: TSpeedButton;
    Grille1: Grille;
    procedure FormShow(Sender:TObject);
    procedure CellulesClick(Sender:TObject);
    procedure CellBitMapClick(Sender:TObject);
  end;
var FormGrille:TFormGrille;Flag:Boolean;Ori:TColor;
implementation
{$R *.dfm}
procedure TFormGrille.CellBitMapClick(Sender:TObject);
begin
  case TSpeedButton(Sender).Tag of
    0:Grille1.CellBitMap(-1,-1);
    1:Grille1.CellBitMap(2,3);     // Cellule 2,3
    2:Grille1.CellBitMap(3,-1);    // Colonne N° 3
    3:Grille1.CellBitMap(-1,2);    // Ligne N° 2
  end;
end;
procedure TFormGrille.CellulesClick(Sender:TObject);
Var i:Integer;
begin
  With Grille1 Do Begin If Flag then CellColor.Color:=Color Else
    CellColor.Color:=Ori;Flag:=Not(Flag);
  For i:= 0 to 4 do ChangeColorCell(i,i);End;
end;
procedure TFormGrille.FormShow(Sender:TObject);
begin
    Flag:=False;With Grille1 Do Begin Ori:=Grille1.CellColor.Color;
    Cells[0,0]:='12345.34';Cells[1,1]:='12.55';Cells[2,2]:='0.75';
    Cells[3,3]:='Guy Bidi';End;
end;
end.