PANEL ET CHECKBOX

unit BFCheckBox;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ExtDlgs, Spin, FileCtrl, ComCtrls;
Const
   PixelCountMax=32768;                                    {Nombre maxi de pixels}
TYPE
   pRGBTripleArray=^TRGBTripleArray;                       {Nom de pointeur}
   TRGBTripleArray=ARRAY[0..PixelCountMax-1]of TRGBTRIPLE; {sur l'ensemble des pixels}
type
  TBFCheckBox = class(TGraphicControl)
  private
    { Déclarations privées }
    FBROUGE:Byte;
    FBVERT:Byte;
    FBBLEU:Byte;
    FBChecked:Boolean;                                  //Case a cocher
    FBChPlein:Boolean;                                  //plein ou coché
    FBTransparent:Boolean;                              //Composant devenant transparent
    FBCaption:string;
    FBReadOnly:Boolean;                                 //Lecture seule

    Procedure SETBROUGE(Value:Byte);
    Procedure SETBVERT(Value:Byte);
    Procedure SETBBLEU(Value:Byte);
    Procedure SETBTRANSPARENT(Value:boolean);
    Procedure SETBCHECKED(Value:boolean);
    Procedure SETBCHPLEIN(Value:boolean);
    Procedure SETBCAPTION(Value:string);
    Procedure SETBReadOnly(Value:boolean);

  protected
    { Déclarations protégées }
    procedure Paint; override;
    Procedure TransformeCheckBox(Var FBRouge, FBVert, FBBleu:Byte;FBTransparent:Boolean;
                                FBChecked:boolean;FBCaption:string);

  public
    { Déclarations publiques }
    constructor Create(AOwner:TComponent); override;
    Destructor Destroy;Override;
    Procedure Click;Override;

  published
    { Déclarations publiées }
   Property ROUGE:Byte READ FBROUGE WRITE SETBROUGE;
   Property VERT:Byte READ FBVERT WRITE SETBVERT;
   Property BLEU:Byte READ FBBLEU WRITE SETBBLEU;
   Property Transparent:Boolean READ FBTransparent WRITE SETBTRANSPARENT;
   Property Checked:Boolean Read FBChecked Write SETBCHECKED;
   Property CHPlein:Boolean READ FBCHPLEIN Write SETBCHPLEIN;
   Property Caption:string READ FBCAPTION WRITE SETBCAPTION;
   Property ReadOnly:Boolean READ FBReadOnly WRITE SETBReadOnly;
   Property Action;
   Property Anchors;
   Property BidiMode;
   Property Constraints;
   Property Cursor;
   Property DragCursor;
   Property DragKind;
   Property DragMode;
   Property Enabled;
   Property Font;
   Property Height;
   Property Hint;
   Property Left;
   Property Name;
   Property ParentBiDiMode;
   Property ParentFont;
   Property ParentShowHint;
   Property PopupMenu;
   Property ShowHint;
   Property Tag;
   Property Top;
   Property Visible;
   Property Width;
   property OnClick;
   property OnDblClick;
   property OnMouseDown;
   property OnMouseMove;
   property OnMouseUp;                                     

  end;

procedure Register;

Var
   Image : Timage;

implementation

procedure TBFCheckBox.Paint;
begin
   inherited Paint;
   with Canvas do
   begin
      TransformeCheckBox(FBrouge,FBvert,FBbleu,FBTransparent,FBChecked,FBCaption);
      Canvas.Draw(0,0,Image.Picture.Graphic);
      Image.Free;
      If FBTransparent= false then
      begin
         Brush.Style:=bsClear;                                {Spécifie le motif du pinceau}
         Pen.Width:=4;                                        {grosseur du pinceau}
         Pen.Color:=RGB(FBROUGE,FBVERT,FBBLEU);               {on récupère la couleur de bordure}
         Rectangle(0,0,Width,Height);                         {on dessine le rectangle}
      end;   
   end;
end;

Procedure TBFCheckBox.TransformeCheckBox(Var FBRouge, FBVert, FBBleu:Byte;FBTransparent:Boolean;
                                FBChecked:boolean;FBCaption:string);
VAR
   Btmap1 : TBitmap;                                {bitmaps}
   I,J,w,h:integer;
   Row:pRGBTripleARRAY;
   Dr,Ha,Hc:Integer;
   D2,D4,D8:integer;
begin
   Image:=TImage.Create(Self);      //Création et dimension de l'image
   Hc:=-Font.Height;                //Hauteur de fonte
   Height:=Hc+6;                    //Hauteur du composant calculée
   Ha:=Hc+2;
   D2:=Round(Ha/2);                //Pour le dessin de la case cochée
   D4:=Round(Ha/4);
   D8:=Round(Ha/8);
   W:=Width;
   H:=Height;
   Image.Width :=W ;
   Image.Height :=H ;
   Btmap1 := TBitmap.Create;
   TRY
      Btmap1.PixelFormat := pf24bit; //Création du bitmap aux mêmes dimentions que l'image
      Btmap1.Width := W;
      Btmap1.Height:=H;
      for J:=0 to BTMap1.Height-1 do //Avec Scanline
      begin
         Row:=BtMap1.Scanline[j];
         for i:=0 to BTMap1.Width-1 do
         begin
            With Row[i] do
            begin
               RGBTRed:=FBRouge;
               RGBTGreen:=FBVert;
               RGBTBlue:=FBBleu;
            end;
         end;
      end;
      With Image do
      begin
         Picture.Graphic := Btmap1; //Récupération de l'image
         Ha:=H-4;
         Dr:=6+Ha;
         Canvas.Brush.Style:=bsClear;
         Canvas.Draw(0,0,Btmap1);
         Canvas.Font.Size:=Font.Size;                      {la grosseur de caractère}
         Canvas.Font.Name:=Font.Name;                      {le nom de la fonte d'écriture}
         Canvas.Font.Color:=Font.Color;                    {la couleur}
         Transparent:=FBTransparent;                       {Transparence}
         if FBCaption<>'' then
         Canvas.textOut(Dr,1,FBCaption);                   {on écrit le texte}
         Canvas.Brush.Style:=bssolid;
         If FBChecked=true then                           //Case cochée
         Begin
            If FBChPlein=true then                        //Carré plein
            begin
               Canvas.Brush.color:=ClBlack;
               Canvas.Rectangle(2,2,Ha,Ha);
            end
            else
            begin
               Canvas.Pen.Width:=1;                      //Case cochée
               Canvas.Brush.color:=ClWhite;
               Canvas.Rectangle(2,2,Ha,Ha);
               Canvas.Brush.color:=ClBlack;
               if Font.size>10 then
               Canvas.Pen.Width:=3;
               Canvas.MoveTo(D4+1,D2+1);
               Canvas.LineTo(d2+1,(7*d8));
               Canvas.LineTo((3*D4),D8);
            end;
         end
         else
         begin                                         //Case non cochée
            Canvas.Pen.Width:=1;
            Canvas.Brush.color:=ClWhite;
            Canvas.Rectangle(2,2,Ha,Ha);
         end;
      END;
   FINALLY
      Btmap1.Free;
   END;
END;

Procedure TBFCheckBox.SETBROUGE(Value:Byte);
Begin
   if Value <> FBROUGE then
   begin
      FBROUGE := Value;
      Invalidate;
   end;
End;

Procedure TBFCheckBox.SETBVERT(Value:Byte);
Begin
   if Value <> FBVERT then
   begin
      FBVERT := Value;
      Invalidate;
   end;
End;

Procedure TBFCheckBox.SETBBLEU(Value:Byte);
Begin
   if Value <> FBBLEU then
   begin
      FBBLEU := Value;
      Invalidate;
   end;
End;

Procedure TBFCheckBox.SETBTRANSPARENT(Value:Boolean);
Begin
   if Value <> FBTransparent then
   begin
      FBTransparent := Value;
      Invalidate;
   end;
End;

Procedure TBFCheckBox.SETBCHECKED(Value:Boolean);
Begin
   if Value <> FBChecked then
   begin
      FBChecked := Value;
      Invalidate;
   end;
End;

Procedure TBFCheckBox.SETBCHPLEIN(Value:boolean);
Begin
   if Value <> FBChPlein then
   begin
      FBChPlein := Value;
      Invalidate;
   end;
End;

Procedure TBFCheckBox.SETBReadOnly(Value:boolean);
Begin
   if Value <> FBReadOnly then
   begin
      FBReadOnly := Value;
      Invalidate;
   end;
end;

Procedure TBFCheckBox.SETBCAPTION(Value:string);
Begin
   if Value <> FBCaption then
   begin
      FBCaption := Value;
      Invalidate;
   end;
end;

Procedure TBFCheckBox.Click;
Begin
   If FBReadOnly=true then
   exit;
   Checked:= Not Checked;
   Invalidate;
   InHerited Click;
end;

constructor TBFCheckBox.Create(AOwner:TComponent);
begin
   inherited;
   Width:=97;
   Height:=17;
   FBRouge:=180;
   FBVert:=180;
   FBBleu:=240;
   FBTransparent:=True;
   FBChecked:=False;
   Checked:=False;
   FBChPlein:=False;
   FBReadOnly:=False;
   FBCaption:='';
end;

Destructor TBFCheckBox.Destroy;
Begin
   Inherited Destroy;
end;

procedure Register;
begin
  RegisterComponents('Exemples', [TBFCheckBox]);
end;
end.