[SOLVED] Add extra property to DBGrid columns
lazarus / 16-Databases

----------------------------------------------------------------------
pcurtis · 2021-03-11 12:57

Hi All,

how can I add a font peoperty called MouseOverFont to this custom
component? [SOLVED]

how can I add an extra TBoolean property to DBGrid columns

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
MyDBGrid; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
LResources, Forms, Controls, Graphics, Dialogs, DBGrids, Grids; type 
TMyDBGrid = class(TDBGrid)  private    function GetMouseOverFont :
TFont;    procedure SetMouseOverFont(aFont : TFont);  protected   
procedure DrawCellText(aCol,aRow : Integer; aRect : TRect;           
              aState : TGridDrawState; aText : String); override;   
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; 
public    constructor Create(AOwner : TComponent); override; 
published    property MouseOverFont : TFont read GetMouseOverFont
write SetMouseOverFont;  end; procedure Register; implementation {$R
mydbgrid.res} constructor TMyDBGrid.Create(AOwner : TComponent);begin 
inherited Create(AOwner);  AlternateColor := clMoneyGreen;  Color :=
clCream;  Options := Options + [dgRowSelect];  Options := Options -
[dgEditing];  AutoFillColumns := true; end; procedure
TMyDBGrid.DrawCellText(aCol, aRow : Integer; aRect : TRect;          
                     aState: TGridDrawState; aText: String);var 
MouseCell : TPoint;begin  MouseCell := GCache.Mousecell;   if (aCol in
[1, 3]) and (aRow >= FixedRows) and  // ignore the header cols/rows  
 (aCol = MouseCell.X) and (aRow = MouseCell.Y)  then    begin     
Canvas.Font := fFont;      {Canvas.Font.Color := clMaroon;     
Canvas.Font.Style := [fsBold, fsItalic, fsUnderline];     
Canvas.Font.Size := 11; }    end;   inherited;end; procedure
TMyDBGrid.MouseMove(Shift: TShiftState; X, Y: Integer);begin 
inherited;  Invalidate;end; function TMyDBGrid.GetMouseOverFont :
TFont;begin  //result := MouseOverFont;end; procedure
TMyDBGrid.SetMouseOverFont(aFont : TFont);begin  If GetMouseOverFont
<> aFont then    begin      //MouseOverFont := aFont;   
end;end; procedure Register;begin 
RegisterComponents('Misc',[TMyDBGrid]);end; end. 
Project attached.

And later I will ask how to add a  boolean property to the Columns
property of the grid. 

Thanks in advance,

----------------------------------------------------------------------
pcurtis · 2021-03-11 19:20

OK, I've got the font bit sorted

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
MyDBGrid; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
LResources, Forms, Controls, Graphics, Dialogs, DBGrids, Grids; type 
TMyDBGrid = class(TDBGrid)  private    fFont : TFont;    function
GetMouseOverFont : TFont;    procedure SetMouseOverFont(aFont :
TFont);  protected    procedure DrawCellText(aCol,aRow : Integer;
aRect : TRect;                           aState : TGridDrawState;
aText : String); override;    procedure MouseMove(Shift: TShiftState;
X, Y: Integer); override;  public    constructor Create(AOwner :
TComponent); override;    destructor Destroy; override;  published   
property MouseOverFont : TFont read GetMouseOverFont write
SetMouseOverFont;  end; procedure Register; implementation {$R
mydbgrid.res} constructor TMyDBGrid.Create(AOwner : TComponent);begin 
inherited Create(AOwner);  AlternateColor := clMoneyGreen;  Color :=
clCream;  Options := Options + [dgRowSelect];  Options := Options -
[dgEditing];  AutoFillColumns := true;  fFont := TFont.Create; 
fFont.Assign(Font);  fFont.Color := clRed;end; destructor
TMyDBGrid.Destroy;begin  fFont.Free;  inherited Destroy;end; procedure
TMyDBGrid.DrawCellText(aCol, aRow : Integer; aRect : TRect;          
                     aState: TGridDrawState; aText: String);var 
MouseCell : TPoint;begin  MouseCell := GCache.Mousecell;   if
(Columns.Items[aCol - 1].FieldName = 'fnIDX') and (aRow >= FixedRows)
and     (aCol = MouseCell.X) and (aRow = MouseCell.Y) then       
Canvas.Font.Assign(fFont);   inherited;end; procedure
TMyDBGrid.MouseMove(Shift: TShiftState; X, Y: Integer);begin 
inherited;  Invalidate;end; function TMyDBGrid.GetMouseOverFont :
TFont;begin  result := fFont;end; procedure
TMyDBGrid.SetMouseOverFont(aFont : TFont);begin  If GetMouseOverFont
<> aFont then    begin      fFont.Assign(aFont);    end;end; procedure
Register;begin  RegisterComponents('Misc',[TMyDBGrid]);end; end. 
Now how can I add the boolean property to the Columns property?

----------------------------------------------------------------------
Soner · 2021-03-11 20:30

Easiest way is you add your properties in dbgrids.pas in TColumn-class
and recompile lazarus. I am doing it for many years.
Lang way look at dbgrid in rxcomponents, he did something similar.

----------------------------------------------------------------------
pcurtis · 2021-03-11 21:51

I prefer not to mess with dbgrid.pas, and to go threw RxDbgrid source
is not in my competence . That's why I need help .

----------------------------------------------------------------------
pcurtis · 2021-03-12 11:39

Done.

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
MyDBGrid; {$mode objfpc}{$H+} interface uses  Classes, SysUtils,
LResources, Forms, Controls, Graphics, StdCtrls, ExtCtrls, Dialogs,
DBGrids, Grids; type  TMyDBGridColumns = class(TColumn)  private   
fMouseOver : boolean;    function GetMouseOver : boolean;    procedure
SetMouseOver(aValue : boolean);  published    property MouseOver :
boolean read GetMouseOver write SetMouseOver;  end; type  TMyDBGrid =
class(TDBGrid)  private    fMouseOverFont : TFont;    fMouseClearFont
: TFont;    function GetMouseOverFont : TFont;    procedure
SetMouseOverFont(aFont : TFont);    function GetMouseClearFont :
TFont;    procedure SetMouseClearFont(aFont : TFont);  protected   
procedure DrawCellText(aCol,aRow : Integer; aRect : TRect;           
              aState : TGridDrawState; aText : String); override;   
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;   
function CreateColumns: TDBGridColumns; override;  public   
constructor Create(AOwner : TComponent); override;    destructor
Destroy; override;  published    property FontMouseOver : TFont read
GetMouseOverFont write SetMouseOverFont;    property FontMouseClear :
TFont read GetMouseClearFont write SetMouseClearFont;    procedure
SetTopRow(aField : string; aRow : variant);  end; procedure
Register; implementation {$R mydbgrid.res} constructor
TMyDBGrid.Create(AOwner : TComponent);begin  inherited
Create(AOwner);  AlternateColor := clMoneyGreen;  Color := clCream; 
Options := Options + [dgRowSelect];  Options := Options -
[dgEditing];  AutoFillColumns := true;  fMouseOverFont :=
TFont.Create;  fMouseOverFont.Assign(Font);  fMouseOverFont.Color :=
clRed;  fMouseClearFont := TFont.Create; 
fMouseClearFont.Assign(Font);  fMouseClearFont.Color :=
clBlue;end; destructor TMyDBGrid.Destroy;begin  fMouseOverFont.Free; 
fMouseClearFont.Free;  inherited Destroy;end; procedure
TMyDBGrid.SetTopRow(aField : string; aRow : variant);var Delta :
integer; LocateRow : integer; TotalRow : integer;begin 
DataSource.DataSet.Locate(aField, aRow, []);  locateRow :=
DataLink.ActiveRecord;  totalRow := DataLink.RecordCount;  delta :=
totalRow - 1;  DataSource.DataSet.MoveBy(delta);  if not
DataSource.DataSet.EOF then    DataSource.DataSet.MoveBy(-delta) 
else    DataSource.DataSet.MoveBy(-totalRow + locateRow +
1);end; function TMyDBGrid.CreateColumns : TDBGridColumns;begin 
Result := TDBGridColumns.Create(Self, TMyDBGridColumns);end; function
TMyDBGridColumns.GetMouseOver : boolean;begin  Result :=
fMouseOver;end; procedure TMyDBGridColumns.SetMouseOver(aValue :
boolean);begin  If GetMouseOver <> aValue then    begin     
fMouseOver := aValue;    end;end;[code=pascal]
procedure TMyDBGrid.DrawCellText(aCol, aRow : Integer; aRect : TRect;
                                 aState: TGridDrawState; aText:
String);
var
  MouseCell : TPoint;
begin
  MouseCell := GCache.Mousecell;

  if aRow >= FixedRows then
    begin
      if (TMyDBGridColumns(Columns.Items[aCol - 1]).MouseOver = true)
then
          if (aCol = MouseCell.X) and (aRow = MouseCell.Y) then
            begin
              Canvas.Font.Assign(fMouseOverFont);
            end
          else
            begin
              Canvas.Font.Assign(fMouseClearFont);
            end;
    end;

  inherited;
end;

procedure TMyDBGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  Invalidate;
end;

function TMyDBGrid.GetMouseOverFont : TFont;
begin
  result := fMouseOverFont;
end;

procedure TMyDBGrid.SetMouseOverFont(aFont : TFont);
begin
  If GetMouseOverFont <> aFont then
    begin
      fMouseOverFont.Assign(aFont);
    end;
end;

function TMyDBGrid.GetMouseClearFont : TFont;
begin
  result := fMouseClearFont;
end;

procedure TMyDBGrid.SetMouseClearFont(aFont : TFont);
begin
  If GetMouseOverFont <> aFont then
    begin
      fMouseClearFont.Assign(aFont);
    end;
end;

procedure Register;
begin
  RegisterComponents('Misc',[TMyDBGrid]);
end;

end.
[/code]