1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
unit ColoredBindNavigator;

interface

 uses System.Classes, System.UIConsts,System.UITypes,
      FMX.Bind.Navigator, Data.Bind.Controls;

/// range TNavigateButton in three groups
const   NavigatorScrollings = [nbFirst, nbPrior, nbNext, nbLast,nbRefresh];
        NavigatorValidations = [nbInsert, nbDelete, nbEdit, nbPost, nbCancel,
                                nbApplyUpdates];
        NavigatorCancelations = [nbDelete,nbCancel,nbCancelUpdates];

type

  TNavigatorColors = record
    scroll : TAlphacolor;
    update : TAlphacolor;
    cancel : TAlphacolor;
    class operator initialize (out Dest: TNavigatorColors);
    class operator finalize (var Dest: TNavigatorColors);
  end;

  TColorNavButton = class helper for TBindNavButton
    /// set the color of the Tpath.fill.color property
    procedure setcolor(c : TAlphaColor);
    /// apply the custom colors corresponding to the TNavigateButton type
    /// Three groups NavigatorScrollings,NavigatorValidations,NavigatorCancelations
    /// see const part
    procedure ApplyColorStyle(customcolors : TNavigatorColors);
  end;

  TColorBindNavigator = class helper for TCustomBindNavigator
    /// initialize and apply custom colors
    function customcolors(scrollcolor, Updatecolor, cancelcolor : TAlphaColor) : TNavigatorColors; overload;
    function customcolors(colors : TNavigatorColors) : TNavigatorColors; overload;
  end;

implementation

{ TColorNavButton }
procedure TColorNavButton.ApplyColorStyle(customcolors : TNavigatorColors);
var defaultstylecolor : TAlphaColor;
begin
inherited;
with Self do
  DefaultStylecolor:=FPath.Fill.Color;
if (TNavigateButton(Self.index) in NavigatorScrollings)
    AND (customcolors.scroll<>TAlphacolors.Alpha)
// todo test    AND (customcolors.scroll<>DefaultStyleColor)
 then Setcolor(customcolors.scroll);
if (TNavigateButton(Self.index) in NavigatorValidations)
    AND (customcolors.update<>TAlphacolors.Alpha)
 then Setcolor(customcolors.update);
if (TNavigateButton(Self.index) in NavigatorCancelations)
    AND (customcolors.cancel<>TAlphacolors.Alpha)
 then Setcolor(customcolors.cancel);
end;

procedure TColorNavButton.setcolor(c: TAlphaColor);
begin
with Self do
   FPath.Fill.Color:=c;
end;

{ TNavigatorColors }
class operator TNavigatorColors.finalize(var Dest: TNavigatorColors);
begin
// nothing to do
end;

class operator TNavigatorColors.initialize(out Dest: TNavigatorColors);
begin
Dest.scroll:=TAlphaColors.Alpha;
Dest.update:=TAlphaColors.Alpha;
Dest.cancel:=TAlphaColors.Alpha;
end;


{ TColorBindNavigator }
function TColorBindNavigator.customcolors(scrollcolor, Updatecolor,
  cancelcolor: TAlphaColor) : TNavigatorColors;
begin
result.scroll:=scrollcolor;
result.update:=updatecolor;
result.cancel:=cancelcolor;
for var i := 0 to  self.ControlsCount-1 do
      TBindNavButton(Self.Controls[i]).ApplyColorStyle(result);
end;

function TColorBindNavigator.customcolors(
  colors: TNavigatorColors): TNavigatorColors;
begin
for var i := 0 to  self.ControlsCount-1 do
      TBindNavButton(Self.Controls[i]).ApplyColorStyle(colors);
end;

end.

1
2
3
4
5
6
7
8
9
10
11
12
13
interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
  Data.Bind.Controls, FMX.Controls.Presentation, FMX.StdCtrls, FMX.Layouts,
  Fmx.Bind.Navigator, FMX.Memo.Types, FMX.ScrollBox, FMX.Memo, FMX.Objects,
  FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Param,
  FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf, FireDAC.DApt.Intf,
  FireDAC.Stan.StorageBin, Data.Bind.Components, Data.Bind.DBScope, Data.DB,
  FireDAC.Comp.DataSet, FireDAC.Comp.Client,
  ColoredBindNavigator;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
type
  TForm1 = class(TForm)
    BindNavigator1: TBindNavigator;
    btnDark: TButton;
    Memo1: TMemo;
    FDMemTable1: TFDMemTable;
    BindSourceDB1: TBindSourceDB;
    Label1: TLabel;
    StyleBook1: TStyleBook;
    Button1: TButton;
    procedure btnDarkClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Déclarations privées }
     Colors : TNavigatorColors;
  public
    { Déclarations publiques }
  end;

1
2
3
4
5
6
procedure TForm1.FormCreate(Sender: TObject);
begin
CustomColorsNavigator :=true;
colors:=BindNavigator1.customcolors(Talphacolors.blue,Talphacolors.Green,Talphacolors.Red);
end;

1
2
3
4
5
6
7
8
9
procedure TForm1.btnDarkClick(Sender: TObject);
begin
 colors.scroll:=Talphacolors.darkBlue;
 colors.update:=Talphacolors.darkGreen;
 colors.cancel:=TAlphacolors.darkRed;
 for var i := 0 to  BindNavigator1.ControlsCount-1 do
      TBindNavButton(BindNavigator1.Controls[i]).ApplyColorStyle(colors);
end;

1
2
3
4
procedure TFormTest.FormCreate(Sender: TObject);
begin
ControlList1.MultiSelect:=True;
end;

1
2
3
4
5
6
7
8
9
10
11
12
procedure TFormTest.btnListeSelectionClick(Sender: TObject);
begin
Memo1.Lines.Clear; // efface l'ancien résultat
for var i:= 0 to ControlList1.ItemCount-1 do   // parcourir l'ensemble des élémnts
  if ControlList1.Selected[i] then                    // élément sélectionné ?
   begin
        ControlList1.ItemIndex:=i;                   // se positionner dessus pour accéder à label1 
        Memo1.Lines.Add(i.ToString+ ' - '
                                   +label1.caption); 
    end;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
procedure TFormTest.btnListeSelectionClick(Sender: TObject);
var lastSelected : integer;
begin
Memo1.Lines.Clear;
// mémorise la position
LastSelected:=ControlList1.ItemIndex;
// au cas où l'élément ne ferait pas partie de la sélection
// ne devrait pas arriver
if not ControlList1.Selected[LastSelected] then LastSelected:=-1;
for var i:= 0 to ControlList1.ItemCount-1 do
  if ControlList1.Selected[i] OR (i=lastSelected)
  then
   begin
        ControlList1.ItemIndex:=i;
        Memo1.Lines.Add(i.ToString+
                        ' - '+label1.caption);
end;
// Se repositionner sur le dernier élément sélectionné
ControlList1.ItemIndex:=LastSelected;
// redessiner la liste
ControlList1.Invalidate;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
procedure TForm31.SpeedButton2ApplyStyleLookup(Sender: TObject);
var Align : TValue;   // méthode styledata
    aGlyph : TGlyph;
    aText : TText;
begin
// méthode styledata. utiliser StyleData a été classée comme obsolète dans certaines versions
//TValue.Make(Ord(TAlignLayout.Client),TypeInfo(TAlignLayout),Align);
//TSpeedButton(Sender).StylesData['glyphstyle.align']:=Align;
//TSpeedButton(Sender).StylesData['text.visible']:=False;

// méthode findStyleResource
(Sender as TSpeedButton).FindStyleResource<TGlyph>('glyphstyle',aGlyph);
if assigned(aglyph) then aGlyph.Align:=TalignLayout.Contents;
(Sender as TSpeedButton).FindStyleResource<TText>('text',aText);
if assigned(aText) then aText.Visible:=False;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
{$R *.dfm}
uses FMX.Styles, FMX.StdCtrls, FMX.Objects, FMX.ImgList;

procedure TDataModule.DataModuleCreate(Sender: TObject);
var  sb,obj: TFmxObject;
     aGlyph : TGlyph;
     aText : TText;
begin
  sb:=TStyleManager.ActiveStyle(nil);
  if assigned(sb) then begin
    obj:=sb.FindStyleResource('icondpeedbutton');
    if not assigned(obj) then
      begin
        obj:=sb.FindStyleResource('toolbutton',true); // duplication d'un style prédéfini. Utilisez un style avec glyphe pour obtenir une icône par défaut  
        if Assigned(obj) then
           begin
            aGlyph:= obj.FindStyleResource('glyphstyle') as TGlyph;
            aGlyph.Align:=TalignLayout.Client;
            aText:= obj.FindStyleResource('text') as TText;
            aText.Visible:=false;
            obj.StyleName:='icondpeedbutton';
            sb.AddObject(obj);
           end;
      end;
  end;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
procedure TForm1.DrawStripesBackground(Sender: TObject;
  const Canvas: TCanvas; const Column: TColumn; const Bounds: TRectF;
  const Row: Integer; const Value: TValue; const State: TGridDrawStates);
var aBrush : TBrush; // 
begin
aBrush:=TBrush.Create(TBrushKind.Solid,TAlphaColors.Null);
try
if  odd(row)
    then aBrush.Color:=TAlphaColors.white
    else aBrush.Color:=TAlphaColors.red;
Canvas.FillRect(Bounds,1,aBrush);
finally
  aBrush.Free;
end;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
procedure TForm3.btnUSAClick(Sender: TObject);
var
  I: Integer;
const  oddstars ='* * * * * *';
       evenstars=' * * * * * *';
begin
StringGrid1.OnDrawColumnBackground:=DrawStripesBackground;
StringGrid1.OnDrawColumnCell:=DrawStarsColumnCell;
Stringgrid1.ClearColumns;
StringGrid1.RowCount:=13;
StringGrid1.RowHeight:=20;
with TColumn.Create(StringGrid1) do  parent:=StringGrid1;
with TColumn.Create(StringGrid1) do  parent:=StringGrid1;
with TColumn.Create(StringGrid1) do  parent:=StringGrid1;
for I := 0 to 7 do
begin
 if odd(i) then StringGrid1.Cells[0,i]:=oddstars
           else StringGrid1.Cells[0,i]:=evenstars;
end;
end;

procedure TForm1.testDrawStarsColumnCell(Sender: TObject; const Canvas: TCanvas;
  const Column: TColumn; const Bounds: TRectF; const Row: Integer;
  const Value: TValue; const State: TGridDrawStates);
var aTextLayout : TTextLayout;
      aRectF : TrectF;
      aBrush : TBrush;
begin
if Value.IsEmpty then exit;

aBrush:=TBrush.Create(TBrushKind.Solid,TAlphaColors.Null);
try
 if (column.Index=0) AND (row<=7) then aBrush.Color:=TAlphaColors.Midnightblue;
 aRectF:=Bounds;
 aRectf.Inflate(3,3); // agrandir le rectangle
 Canvas.FillRect(aRectF,1,aBrush);

 // utilisation d'un TextLayout plutôt qu'un simple Canvas.Drawtext
 // permet de changer la couleur, la taille de la fonte, l'alignement etc... 
 ATextLayout:=TTextLayoutManager.TextLayoutByCanvas(Canvas.ClassType).Create(Canvas);
 ATextLayout.BeginUpdate;
 ATextLayout.Text:=Value.ToString;
 ATextLayout.Color:=Talphacolors.Antiquewhite;
 ATextLayout.TopLeft:=Bounds.TopLeft;
 ATextLayout.MaxSize := PointF(ArectF.Width, aRectf.Height);
 ATextLayout.Font.Size:=20;
 ATextLayout.VerticalAlign:=TTextAlign.Center;
 ATextLayout.HorizontalAlign:=TTextAlign.Center;
 ATextLayout.EndUpdate;
 ATextLayout.RenderLayout(Canvas);
finally
 ATextLayout.Free;
 aBrush.Free;
end; 
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
procedure TForm1.btnPionsClick(Sender: TObject);
var
  I: Integer;
  c : string;  // couleur du pion
begin
if Tbutton(Sender).Tag=0 then c:='b' else c:='w';  // choix blancs ou noirs

StringGrid1.OnDrawColumnBackground:=StringGrid1DrawChessBackground;
StringGrid1.OnDrawColumnCell:=StringGrid1DrawPawnColumnCell;

Stringgrid1.ClearColumns;
StringGrid1.RowCount:=8;
StringGrid1.RowHeight:=40;
stringGrid1.Height:=347;
stringGrid1.width:=347;

for I := 1 to 8 do
  begin
    with TColumn.Create(StringGrid1) do
     begin
       parent:=StringGrid1;
       width:=40;
     end;
  end;
for I := 0 to 7 do
   StringGrid1.Cells[i,1]:='P'+c;
StringGrid1.Cells[0,0]:='T'+c;
StringGrid1.Cells[7,0]:='T'+c;
StringGrid1.Cells[1,0]:='C'+c;
StringGrid1.Cells[6,0]:='C'+c;
StringGrid1.Cells[2,0]:='B'+c;
StringGrid1.Cells[5,0]:='B'+c;
StringGrid1.Cells[3,0]:='Q'+c;
StringGrid1.Cells[4,0]:='K'+c;
if c='w' then c:='b' else c:='w';
for I := 0 to 7 do
   StringGrid1.Cells[i,6]:='P'+c;
StringGrid1.Cells[0,7]:='T'+c;
StringGrid1.Cells[7,7]:='T'+c;
StringGrid1.Cells[1,7]:='C'+c;
StringGrid1.Cells[6,7]:='C'+c;
StringGrid1.Cells[2,7]:='B'+c;
StringGrid1.Cells[5,7]:='B'+c;
StringGrid1.Cells[3,7]:='Q'+c;
StringGrid1.Cells[4,7]:='K'+c;
end;

procedure TForm1.StringGrid1DrawChessBackground(Sender: TObject;
  const Canvas: TCanvas; const Column: TColumn; const Bounds: TRectF;
  const Row: Integer; const Value: TValue; const State: TGridDrawStates);
var aBrush : TBrush;
begin
aBrush:=TBrush.Create(TBrushKind.Solid,TAlphaColors.Null);
 try
   if (odd(column.Index) AND odd(row)) OR NOT(odd(column.Index) OR odd(row))
     then aBrush.Color:=TAlphaColors.Ivory
     else aBrush.Color:=TAlphaColors.Chocolate;
   Canvas.FillRect(Bounds,1,aBrush);
 finally
  aBrush.Free;
 end;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
procedure TForm3.StringGrid1DrawColumnCell(Sender: TObject;
  const Canvas: TCanvas; const Column: TColumn; const Bounds: TRectF;
  const Row: Integer; const Value: TValue; const State: TGridDrawStates);
const bishop='M19,22H5V20H19V22M17.16,8.26C18.22,9.63 18.86,11.28 19,13C19,15.76 15.87,18 12,18'+
             'C8.13,18 5,15.76 5,13C5,10.62 7.33,6.39 10.46,5.27C10.16,4.91 10,4.46 10,4A2,2 0 0,1'+
             ' 12,2A2,2 0 0,1 14,4C14,4.46 13.84,4.91 13.54,5.27C14.4,5.6 15.18,6.1 15.84,6.74L11.29,11.29L12.71,12.71L17.16,8.26Z';
      king='M19,22H5V20H19V22M17,10C15.58,10 14.26,10.77 13.55,12H13V7H16V5H13V2H11V5H8V7H11V12H10.45C9.35,10.09 6.9,9.43 5,10.54C3.07,11.64 2.42,14.09 3.5,16C4.24,17.24 5.57,18 7,18H17A4,4 0 0,0 21,14A4,4 0 0,0 17,10Z';
      cavalier='M19,22H5V20H19V22M13,2V2C11.75,2 10.58,2.62 9.89,3.66L7,8L9,10L11.06,8.63C11.5,8.32 '+
               '12.14,8.44 12.45,8.9C12.47,8.93 12.5,8.96 12.5,9V9C12.8,9.59 12.69,10.3 12.22,10.77L7.42,15.57C6.87,16.13 6.87,17.03 7.43,17.58C7.69,17.84 8.05,18 8.42,18H17V6A4,4 0 0,0 13,2Z';
      pion='M19 22H5V20H19V22M16 18H8L10.18 10H8V8H10.72L10.79 7.74C10.1 7.44 9.55 6.89 9.25 6.2C8.58 4.68 9.27 2.91 10.79 2.25C12.31 1.58 14.08 2.27 14.74 3.79C15.41 5.31 14.72 7.07 13.2 7.74L13.27 8H16V10H13.82L16 18Z';
      queen='M18,3A2,2 0 0,1 20,5C20,5.81 19.5,6.5 18.83,6.82L17,13.15V18H7V13.15L5.17,6.82'+
            'C4.5,6.5 4,5.81 4,5A2,2 0 0,1 6,3A2,2 0 0,1 8,5C8,5.5 7.82,5.95 7.5,6.3L10.3,9.35L10.83,5.62C10.33,5.26 10,4.67 10,4A2,2 0 0,1 12,2A2,2 0 0,1 14,4C14,4.67 13.67,5.26 13.17,5.62L13.7,9.35L16.47,6.29C16.18,5.94 16,5.5 16,5A2,2 0 0,1 18,3M5,20H19V22H5V20Z';
      tower='M5,20H19V22H5V20M17,2V5H15V2H13V5H11V2H9V5H7V2H5V8H7V18H17V8H19V2H17Z';

 var aBrush : TBrush;
    aRectf : TRectF;
    aPath : TPath;

begin
if Value.IsEmpty then  exit;
aBrush:=TBrush.Create(TBrushKind.Solid,TAlphaColors.Null);
 try
// effacer le texte existant 
  aRectF:=Bounds;
  aRectf.Inflate(3,3);
  aRectF.Left:=aRectf.Left-3;
  if (odd(column.Index) AND odd(row)) OR NOT(odd(column.Index) OR odd(row))
    then aBrush.Color:=TAlphaColors.Ivory
    else aBrush.Color:=TAlphaColors.Chocolate;
  Canvas.FillRect(arectf,1,aBrush);

  if value.ToString.EndsWith('w') then ABrush.color:=Talphacolors.Aqua
                                else ABrush.color:=Talphacolors.black;
 // remplacement du texte par un dessin SVG
  aPath:=Tpath.Create(nil);
  if value.ToString.StartsWith('K') then aPath.Data.Data:=King;
  if value.ToString.StartsWith('Q') then aPath.Data.Data:=Queen;
  if value.ToString.StartsWith('B') then aPath.Data.Data:=bishop;
  if value.ToString.StartsWith('C') then aPath.Data.Data:=cavalier;
  if value.ToString.StartsWith('T') then aPath.Data.Data:=Tower;
  if value.ToString.StartsWith('P') then aPath.Data.Data:=Pion;
  aPath.Fill:=aBrush;
  aPath.width:=40;
  aPath.Height:=40;
  aPath.Parent:=Self;
  aPath.PaintTo(Canvas,Bounds,Stringgrid1); // dessin dans la grille
finally
 aPath.free;
 aBrush.free;
end;

end;

1
2
3
4
5
6
7
8
9
10
11
12
13
TStringGrid2Clipboard = class helper for TStringGrid
  private
    function AddStringSeparator(const s : String; const stringseparator : Char) : String;
  public
    // fonctions sur tableau
    function FullGrid2Clipboard(const addheader : boolean = true; const stringseparator : char =#0) : boolean;
    function SelectColumns2Clipboard(var Cols : TArray<integer>; const addheader : boolean = false; const stringseparator : char =#0) : boolean;
    function SelectRows2Clipboard(var Rows : TArray<integer>; const addheader : boolean = false; const stringseparator : char =#0) : boolean;
    function SelectColRows2Clipboard(var Cols,Rows : TArray<integer>; const addheader : boolean = false; const stringseparator : char = #0) : boolean;
    // fonction sur sélection de cellules
    function CellRange2ClipBoard(var Selected : TRect ; const addheader : boolean = false; const stringseparator : char =#0) : boolean;
  end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
object TStyleContainer
  object TImage
    StyleName = 'modele'
    MultiResBitmap.Height = 400
    MultiResBitmap.Width = 400
    MultiResBitmap = <
      item
        Width = 400
        Height = 400
        PNG = {
          89504E470D0A1A0A0000000D494844520000019000000190080600000080BF36
          CC000000017352474200AECE1CE90000000467414D410000B18F0BFC61050000
          FFBA49444154785EECBD07A0654771E75D2FE737392AA2882414404248800011
<!-- je vous fais grâce des quelque 2700 lignes suivantes de l''image -->
         66FB0FEEB55FF8D0476CDFCEFD9136373F671DED1DE107350352A142850A152A
          340EB3FF13E4E33CC0A3EE7CFE0000000049454E44AE426082}
        FileName = 
          'D:\serge\Documents\Embarcadero\Studio\Projets\Sidney\stoneedge.png'
      end>
    Align = Center
    Size.Width = 274.000000000000000000
    Size.Height = 269.000000000000000000
    Size.PlatformDefault = False
    Visible = False
  end
  object TLayout
    StyleName = 'piece01'
    Align = Center
    Visible = False
    TabOrder = 3
    object TStyleObject
      StyleName = 'StyleObject1Style'
      SourceLookup = 'Modele'
      SourceLink = <
        item
          SourceRect.Left = 2.000000000000000000
          SourceRect.Top = 1.000000000000000000
          SourceRect.Right = 100.000000000000000000
          SourceRect.Bottom = 100.000000000000000000
        end>
    end
  end
  object TLayout
    StyleName = 'piece02'
    Align = Center
    Visible = False
    TabOrder = 2
    object TStyleObject
      StyleName = 'StyleObject1Style'
      SourceLookup = 'Modele'
      SourceLink = <
        item
          SourceRect.Left = 100.000000000000000000
          SourceRect.Right = 200.000000000000000000
          SourceRect.Bottom = 100.000000000000000000
        end>
    end
  end
  object TLayout
    StyleName = 'piece05'
    Align = Center
    TabOrder = 1
    object TStyleObject
      StyleName = 'StyleObject1Style'
      SourceLookup = 'Modele'
      SourceLink = <
        item
          SourceRect.Top = 100.000000000000000000
          SourceRect.Right = 100.000000000000000000
          SourceRect.Bottom = 200.000000000000000000
        end>
    end
  end
 end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
  object TLayout
    StyleName = 'piece01'
    Align = Center
    Visible = False
    TabOrder = 3
    object TStyleObject
      StyleName = 'StyleObject1Style'
      SourceLookup = 'Modele'
      SourceLink = <
        item
          SourceRect.Left = 2.000000000000000000
          SourceRect.Top = 1.000000000000000000
          SourceRect.Right = 100.000000000000000000
          SourceRect.Bottom = 100.000000000000000000
        end>
    end
  end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
procedure TMainForm.ButtonChangeImageClick(Sender: TObject);
var pStream : TMemoryStream;
    pFMXObj : TFMXObject;
begin
 
// Passage de l'image via un stream
pStream:=TMemoryStream.Create;
try
  PStream.LoadFromFile('test1.png');
  pFMXObj:=StyleBook1.Style.FindStyleResource('modele');
  if Assigned(pFMXObj) then
    begin
      PStream.Position:=0;
      TImage(pfMXObj).Bitmap.LoadFromStream(Pstream);
    end;
finally
  pStream.Free;
end;
 
//pFMXObj:=StyleBook1.Style.FindStyleResource('modele');
//if Assigned(pFMXObj) then
//    begin
//      TImage(pfMXObj).Bitmap.LoadFromFile('test1.png');
//    end;
 
// Forcer le dessin du GridLayout
GridLayout1.BeginUpdate;
GridLayout1.EndUpdate;
 
// variante Repaint par piece
//for var i:= 0 to GridLayout1.ChildrenCount-1 do
//  TPanel(Gridlayout1.Children[i]).Repaint;
 
 
// Variante re-dessin complet
//for var i:= GridLayout1.ChildrenCount-1 downto 0 do
//  Gridlayout1.Children[i].Free;
//
//for var i := 1 to 16 do
//   begin
//     with TPanel.Create(Self) do
//      begin
//         StyleLookup:=Format('piece%.2d',[i]);
//         Parent:=GridLayout1;
//     end;
//   end;
end;

ACanvas.Brush.Color := StrToInt(lblColorValue.Caption);

ACanvas.Brush.Color := Couleurs.DataGenerator.FindField('Color1').GetTValue.AsInteger;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
procedure TFormCouleurs.ControlList1BeforeDrawItem(AIndex: Integer;
  ACanvas: TCanvas; ARect: TRect; AState: TOwnerDrawState);
var
  FontColor: TColor;

  function IsDark(AColor: TColor): Boolean;
  // Paul Toth
  var
    Color: Integer;
  begin
    Color := ColorToRGB(AColor); // conversion clXXX en couleur RGB
    Result := 0.2125 * TColorRec(Color).R + 0.7174 * TColorRec(Color).G + 0.0721
      * TColorRec(Color).B <= 128;
  end;

begin
  ACanvas.Brush.Color := Couleurs.DataGenerator.FindField('Color1').GetTValue.AsInteger;
  ACanvas.FillRect(ARect);

  if IsDark(ACanvas.Brush.Color) then
    FontColor := clWhite
  else
    FontColor := clBlack;
  LblCouleur.Font.Color := FontColor;
  LblItem.Font.Color := FontColor;
  LblItem.Caption := Format('Item n°%d', [AIndex]);
end;

1
2
3
4
5
6
7
8
9
procedure TFormCouleurs.ControlList1AfterDrawItems(ACanvas: TCanvas;
  ARect: TRect);
begin
  // positionnement dans "fichier"
  Couleurs.ItemIndex := ControlList1.ItemIndex;
  // écriture des valeurs
  Couleur.Brush.Color := Couleurs.DataGenerator.FindField('Color1').GetTValue.AsInteger;
  NomCouleur.Caption := Couleurs.DataGenerator.FindField('ColorsName1').GetTValue.AsString;
end;

1
2
3
4
5
6
7
8
9
procedure TFormCouleurs.ControlList1ItemClick(Sender: TObject);
begin
  NumberBox1.Value := ControlList1.ItemIndex;
end;

procedure TFormCouleurs.FormCreate(Sender: TObject);
begin
  NumberBox1.MaxValue := ControlList1.ItemCount - 1;
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
unit UCtrlListContacts;

interface

uses System.SysUtils
  // nécessaire pour obtenir la date système, le type TFileName
    , System.Generics.Collections
  // nécessaire pour la déclaration de liste d'objets
    , System.Generics.Defaults, System.Classes, System.types,
  System.NetEncoding, System.DateUtils // nécessaire pour EncodeDate
    , VCL.graphics, VCL.Imaging.pngimage, System.UITypes;
type
  TContact = Class
  strict private
    FNom: String;
    FDate: String;
    FPhoto: TPicture;
  private
    // ...
    procedure SetNom(const Value: String);
    procedure SetDate(const Value: String);
    procedure SetPhoto(const Value: TPicture);
  public
    constructor Create(); overload;
    constructor Create(Nom: String; UneDate: String; Photo: TPicture); overload;
    property ContactNom: String read FNom write SetNom;
    property ContactDate: String read FDate write SetDate;
    property ContactPhoto: TPicture read FPhoto write SetPhoto;
  end;

// ..
var
  MesContacts: TObjectList<TContact>;

implementation
//...
initialization
   MesContacts := TObjectList<TContact>.Create;

1
2
3
4
5
6
7
procedure TForm14.ContactsCreateAdapter(Sender: TObject;
  var ABindSourceAdapter: TBindSourceAdapter);
begin
 P_DonneesInternes; // charge les données, fonction de classe
 ABindSourceAdapter:=TListBindSourceAdapter<TContact>.Create(self,MesContacts, True);  // remplace les données du TPrototypeBindSource
 ControlList1.ItemCount:=MesContacts.Count;  // Nombre d'élément dans la liste
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
procedure TForm14.ControlList1AfterDrawItems(ACanvas: TCanvas; ARect: TRect);
var aStream : TMemoryStream;
    avar : TPicture;
begin
if  Contacts.ItemIndex<>ControlList1.ItemIndex then Contacts.ItemIndex:=ControlList1.ItemIndex;
Nom.Text:=MesContacts[ControlList1.ItemIndex].ContactNom;
DateC.Date:=StrToDate(MesContacts[ControlList1.ItemIndex].ContactDate);
// partie chargement image
aStream:=TmemoryStream.Create;
try
    avar:=MesContacts[ControlList1.ItemIndex].ContactPhoto;
    if assigned(avar) then
     begin
      avar.savetostream(astream);
      aStream.Position:=0;
      Photo.Picture.LoadFromStream(aStream);
     end;
finally
  aStream.Free;
end;

1
2
3
4
5
procedure TFormDragdrop.ControlListImagesBeforeDrawItem(AIndex: Integer; ACanvas: TCanvas;
  ARect: TRect; AState: TOwnerDrawState);
begin
  VirtualImage3.ImageIndex := AIndex;
end;

1
2
3
4
5
6
7
8
9
10
11
procedure TFormDragdrop.ControlListGaucheBeforeDrawItem(AIndex: Integer; ACanvas: TCanvas;
  ARect: TRect; AState: TOwnerDrawState);
var
  imagenumber: Integer;
begin
  lblTitre.Caption := 'Item ' + AIndex.ToString;   // affichage du titre
  if ItemImages.TryGetValue(AIndex, imagenumber) then  // affichage de l'image chosie
    VirtualImage1.ImageIndex := imagenumber
  else
    VirtualImage1.ImageIndex := -1;
end;

1
2
3
4
5
6
7
procedure TFormDragdrop.ControlListImagesMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  itemidx := ControlListImages.ItemIndex;  // mémorisation de l'index 
  if (Button = mbLeft) AND (ssShift in Shift) then
    ControlListImages.BeginDrag(true);
end;

1
2
3
4
5
procedure TFormDragdrop.ControlListGaucheDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  Accept := Source is TControlList;
end;

procedure TFormDragdrop.ControlListGaucheDragDrop(Sender, Source: TObject; X, Y: Integer);

1
2
type
  THackCtrlList = class(TControlList);

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
private
 ...
    function ItemAtPos(AX, AY: Integer; var ARect: TRect): Integer; // celle-ci est celle qui nous serait utile
..    
     // les diverses fonctions suivantes montrent aussi un intérêt pour les déplacements  
    function GetFirstDrawItemIndex: Integer;
    function GetLastDrawItemIndex: Integer;
    procedure ScrollToItem(AIndex: Integer; ASelect: Boolean; AUpdate: Boolean);
    procedure FindFirstItem;
    procedure FindLastItem;
    procedure FindLeftItem;
    procedure FindRightItem;
    procedure FindUpItem;
    procedure FindDownItem;
    procedure FindPageUpItem;
    procedure FindPageDownItem;
...

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
unit ControlListHelper;

interface

uses WinApi.Windows, WinApi.Messages,
  System.Types, System.Math, System.Classes, System.Generics.Collections,
  Vcl.ControlList;

type
  TControlListHelper = class helper for TCustomControlList
  public
    function _Columns : Integer;
    function _Rows : Integer;
    function _ItemAtPos(X, Y: Integer;
                        iv: TDictionary<Integer, TRect>=nil): Integer;
    function _GetItemRect(AIndex : Integer): TRect;
    procedure _PageDown;
    procedure _PageUp;
    procedure _PageLeft;
    procedure _PageRight;
    procedure _Home;
    procedure _End;
  end;

var VisibleItems : TDictionary<integer,TRect>;

implementation

{ TControlListHelper }


/// <summary>
/// Get the rect of the drawed item on the TControlList
/// </summary>
/// <param name="AIndex">
///   Index of the item
/// </param>
/// <returns>a TRect
/// </returns>
function TControlListHelper._GetItemRect(AIndex : Integer): TRect;
begin
  Result := TRect.Empty;
  case InternalColumnLayout of
    cltSingle:
      begin
        Result.Top := ItemHeight * AIndex;
        Result.Height := ItemHeight;
        Result.Width := IfThen(ItemWidth = 0, Width - 28, ItemWidth);
      end;
    cltMultiTopToBottom:
      begin
        var Cols : integer :=_Columns;
        Result.Left := (AIndex mod Cols) * ItemWidth;
        Result.Top := ((AIndex div Cols) * ItemHeight);
        Result.Height := ItemHeight;
        Result.Width := ItemWidth;
      end;
    cltMultiLeftToRight:
      begin
        var Rows : integer :=_Rows;
        Result.Left := (AIndex div Rows) * ItemWidth;
        Result.Top := (AIndex mod Rows) * ItemHeight;
        Result.Height := ItemHeight;
        Result.Width := ItemWidth;
      end;
  end;
end;

/// <summary>
/// Get index of the TControlList item
/// </summary>
/// <param name="X">
///  X coordinate of the mouse
/// </param>
/// <param name="Y">
///  Y coordinate of the mouse
/// </param>
/// <param name="iv">
///  Items visible on the TControlList
///  a TDictionary<Integer,TRect> to implement during OnDrawItem or AfterDrawItem event
/// </param>
/// <remarks>
///
/// </remarks>
/// <returns>Item index; -1 if invalid
/// </returns>
function TControlListHelper._ItemAtPos(X, Y: Integer;
  iv: TDictionary<Integer, TRect>=nil): Integer;
var
  I: Integer;
  ofHorz, ofVert: Integer;
  ARect: TRect;
begin
  if not Assigned(iv) then iv:=VisibleItems;
  ofHorz := GetScrollPos(Handle, SB_HORZ);
  ofVert := GetScrollPos(Handle, SB_VERT);
  Result := -1;
  for I := 0 to ItemCount - 1 do
  begin
    if iv.TryGetValue(I, ARect) then
    begin
      if ARect.Contains(TPoint.Create(X + ofHorz, Y + ofVert)) then
        exit(I);
    end;
  end;
end;

/// <summary>
/// Get number of columns of the TControlList
/// </summary>
/// <returns>Number of columns
/// </returns>
function TControlListHelper._Columns: Integer;
begin
case InternalColumnLayout of
  cltSingle : result:=1;
  cltMultiTopToBottom : result:=ClientWidth div ItemWidth;
  cltMultiLeftToRight : begin
                           var nr : integer := _Rows;
                           result:=ItemCount div nr;
                           if (ItemCount mod nr)>0 then inc(Result);
                        end;
 end;
end;

/// <summary>
/// Get number of rows of the TControlList
/// </summary>
/// <returns>Number of rows
/// </returns>
function TControlListHelper._Rows: Integer;
begin
result:=1;
case InternalColumnLayout of
  cltSingle : result:=ItemCount;
  cltMultiTopToBottom : begin
                          var nc : integer := _Columns;
                          result:=ItemCount div nc;
                          if (ItemCount mod nc)>0 then inc(result);
                        end;
  cltMultiLeftToRight : result:=ClientHeight div ItemHeight;
 end;
end;

/// <summary>
/// For gesture usage ???
/// </summary>
procedure TControlListHelper._PageDown;
begin
SendMessage(Handle, WM_KEYDOWN, VK_NEXT, 0);
end;

procedure TControlListHelper._PageUp;
begin
SendMessage(Handle, WM_KEYDOWN, VK_PRIOR, 0);
end;

procedure TControlListHelper._PageLeft;
begin
SendMessage(Handle, WM_KEYDOWN, VK_LEFT, 0);
end;

procedure TControlListHelper._PageRight;
begin
SendMessage(Handle, WM_KEYDOWN, VK_RIGHT, 0);
end;

procedure TControlListHelper._Home;
begin
SendMessage(Handle, WM_KEYDOWN, VK_HOME, 0);
end;

procedure TControlListHelper._End;
begin
SendMessage(Handle, WM_KEYDOWN, VK_END, 0);
end;

initialization
  VisibleItems := TDictionary<integer,TRect>.Create;
finalization
  VisibleItems.Free;
end.

Index:=ControlListGauche._ItemAtPos(X,Y);