Déclarer une propriété TFont dans un composant

Version imprimable

Dans la dbGrid native de lazarus, il n'est pas possible de modifier la Font d'une ligne sélectionnée :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
procedure TCustomDBGrid.DoPrepareCanvas(aCol, aRow: Integer;
  aState: TGridDrawState);
var
  DataCol: Integer;
  IsSelected: boolean;
begin
  if (ARow>=FixedRows) then begin
 
    if not DefaultDrawing then begin
      GetSelectedState(aState, IsSelected);
      if IsSelected then begin
        Canvas.Brush.Color := SelectedColor;
        Canvas.Font.Color := clHighlightText;
      end;
    end;
 
    if Assigned(OnPrepareCanvas) then begin
      DataCol := ColumnIndexFromGridColumn(aCol);
      if DataCol>=0 then
        OnPrepareCanvas(Self, DataCol, TColumn(Columns[DataCol]), aState);
    end;
 
  end;
end;

Je remplace donc dans ma propre dbGrid : Canvas.Font.Color := clHighlightText; par Canvas.Font:= FSelectedFont.

Je déclare la nouvelle propriété ainsi :

Code:

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
  TlzDbGrid = class(TDbGrid)
 
  private
    { Private declarations }
 
 
    FSelectedFont : TFont;
 
    procedure SetSelectedFont(Value: TFont);
    [...] 
  end;
 
constructor TlzDbGrid.Create(AOwner: TComponent);
var
  AGrid: TCustomGrid;
begin
 
  inherited Create(AOwner);
 
  FSelectedFont := TFont.Create;
  FSelectedFont := aGrid.Font;  
  end;
end;             
 
destructor TlzDbGrid.Destroy;
begin
  FreeThenNil(FSelectedFont);
  inherited Destroy;
end; 
 
procedure TlzDbGrid.SetSelectedFont(Value : Tfont);
var
  AGrid: TCustomGrid;
begin
   if Value<>nil then
    FSelectedFont.Assign(Value)
  else
    FSelectedFont := agrid.Font;
end;

Je passe par la Font d'une CustomGrid pour éviter un problème de nil si FSelectedFont n'est pas initialisée. Mais visiblement cela ne fonctionne pas. En plus j'ai un doute concernant l'affectation d'une TFont : FSelectedFont.Assign(Value) ou FSelectedFont := agrid.Font; ?

Je suis preneur de toute aide. Merci. Gilles

Salut,

Plusieurs petites choses dans ton code :

- Tes variables local "agrid" ne sont jamais initialisées, c'est surprenant qu'aucunes exceptions ne soit levées
- FSelectedFont de TLzDBGrid n'est jamais assigné au "canvas"

j'essayerai de surcharger DoPrepareCanvas avec un truc dans le genre :

Code:

1
2
3
4
5
6
7
8
9
procedure TLZDBGrid.DoPrepareCanvas(aCol, aRow: Integer; aState: TGridDrawState);
begin
    if odd(aRow) then
    begin
        Canvas.Font := FSelectedFont;
    end
 
    inherited DoPrepareCanvas(aCol, aRow, aState);
end;

Ou sinon essayes d'assigner OnPrepareCanvas du TDbGrid avec ta propre procedure

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
constructor TlzDbGrid.Create(AOwner: TComponent);
begin
 
  inherited Create(AOwner);
 
  FSelectedFont := TFont.Create;
//  FSelectedFont := aGrid.Font;  pas besoin normalement TFont.Create = Font par defaut du systeme sinon FSelectedFont.Assign(Self.Font);
  Self.OnPrefpareCanvas =@MyDoPrepareCanvas;
end; 
 
procedure TLZDBGrid.MyDoPrepareCanvas(aCol, aRow: Integer; aState: TGridDrawState);
begin
    if odd(aRow) then
    begin
        Canvas.Font := FSelectedFont;
    end;
 
   if Assigned(OnPrepareCanvas) then begin
      DataCol := ColumnIndexFromGridColumn(aCol);
      if DataCol>=0 then
        OnPrepareCanvas(Self, DataCol, TColumn(Columns[DataCol]), aState);
    end;
 
end;

A+

11/03/2019, 22h00
Invité

Bonjour,

Merci je teste cela demain.
Cordialement. Gilles

OK. C'est réglé. J'ai préféré overrider (sans inherited) la méthode DoPrepareCanvas. Merci pour votre aide.
Cordialement. Gilles

Code:

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
 
 TlzDbGrid = class(TDbGrid)
  private
    { Private declarations }
    FSelectedFont: TFont;
    procedure SetSelectedFont(const Value: TFont);
  protected
    { Protected declarations }
    procedure DoPrepareCanvas(aCol,aRow:Integer; aState: TGridDrawState); override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
     property SelectedFont: TFont read FSelectedFont write SetSelectedFont;
  end;    
constructor TlzDbGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSelectedFont := TFont.Create;
  FocusColor := clNone; {   Petite astuce pour enlever l'affreux liseret rouge de la sélection } 
end; 
destructor TlzDbGrid.Destroy;
begin
  FreeThenNil(FSelectedFont);
  inherited Destroy;
end;
procedure TlzDbGrid.SetSelectedFont(const Value: TFont);
begin
  if Value = nil then
    FSelectedFont.Assign(Font)
  else
    FSelectedFont.Assign(Value);
end;
 
procedure TlzDbGrid.DoPrepareCanvas(aCol, aRow: integer; aState: TGridDrawState);
var
  DataCol: integer;
  IsSelected: boolean;
begin
 
  if (ARow >= FixedRows) then
  begin
    // if not DefaultDrawing then begin
    GetSelectedState(aState, IsSelected);
    if IsSelected then
    begin
      Canvas.Brush.Color := SelectedColor;
      Canvas.Font.Assign(FSelectedFont);
    end;
    // end;
 
    if Assigned(OnPrepareCanvas) then
    begin
      DataCol := ColumnIndexFromGridColumn(aCol);
      if DataCol >= 0 then
        OnPrepareCanvas(Self, DataCol, TColumn(Columns[DataCol]), aState);
    end;
  end;
end;

Cela approche du résultat cherché.
Pièce jointe 457235
Tri automatique intégré avec indicateur graphique, élargissement automatique de la colonne souhaitée, refresh intégré avec replacement... Il reste à intégrer un champ de recherche dans la case des Titles... et régler ce fameux problème de Dataset générique pour que l'ensemble soit compatible SQLQuery, UniQuery voire Zeos.