Checkbox in TStringGrid

[NelsonN]

Here is some code which I got from Borland about a year ago. It adds checkbox capabilities to TStringGrids. I tried using it in my current Lazarus project but I get a bunch of errors I am not sure how to fix.

This is more of a request for someone with experience in converting Delphi code to Lazarus/Free Pascal. Can anyone here convert this to work with Lazarus/Free Pascal? I would really appreciate it, and so will others in need of such a feature.

Code: [Select]


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  StdCtrls, ExtCtrls, Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure StringGrid1Click(Sender: TObject);
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure StringGrid1KeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
    FCheck, FNoCheck: TBitmap;
    procedure ToggleCheckbox(acol, arow: Integer);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
type
  TGridCracker = Class( TStringgrid );

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  grid: TStringgrid;
begin
  If not ( gdFixed In State ) and (aCol = 1) Then Begin
    grid:= Sender As TStringgrid;
    With grid.Canvas Do Begin
      brush.color := $E0E0E0;
      // checkboxes look better on a non-white background
      Fillrect( rect );
      // listbox state is encoded by the Objects property
      If Assigned(grid.Objects[aCol, aRow]) Then
        Draw( (rect.right + rect.left - FCheck.width) div 2,
              (rect.bottom + rect.top - FCheck.height) div 2,
              FCheck )
      Else
        Draw( (rect.right + rect.left - FNoCheck.width) div 2,
              (rect.bottom + rect.top - FNoCheck.height) div 2,
              FNoCheck )
    End;
  End;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  bmp: TBitmap;
begin
  FCheck:= TBitmap.Create;
  FNoCheck:= TBitmap.Create;
  bmp:= TBitmap.create;
  try
    bmp.handle := LoadBitmap( 0, PChar(OBM_CHECKBOXES ));
    // bmp now has a 4x3 bitmap of divers state images
    // used by checkboxes and radiobuttons
    With FNoCheck Do Begin
      // the first subimage is the unchecked box
      width := bmp.width div 4;
      height := bmp.height div 3;
      canvas.copyrect( canvas.cliprect, bmp.canvas, canvas.cliprect );
    End;
    With FCheck Do Begin
      // the second subimage is the checked box
      width := bmp.width div 4;
      height := bmp.height div 3;
      canvas.copyrect(
        canvas.cliprect,
        bmp.canvas,
        rect( width, 0, 2*width, height ));
    End;
  finally
    bmp.free
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FNoCheck.Free;
  FCheck.Free;
end;

procedure TForm1.StringGrid1Click(Sender: TObject);
var
  pt: TPoint;
  grid: TStringgrid;
  aCol, aRow: Integer;
begin
  GetCursorPos( pt );
  grid := Sender As TStringgrid;
  pt:= grid.ScreenToClient( pt );
  grid.MouseToCell( pt.x, pt.y, aCol, aRow );
  If (aCol = 1) and (aRow >= grid.fixedRows) Then Begin
    // click landed in a checkbox cell
    ToggleCheckbox( aCol, aRow );
  End;
end;

procedure TForm1.ToggleCheckbox( acol, arow: Integer );
begin
  If aCol = 1 Then
    With TGridCracker( stringgrid1 ) Do Begin
      If Assigned( Objects[aCol, aRow] ) Then
        Objects[aCol, aRow] := Nil
      Else
        Objects[aCol, aRow] := Pointer(1);
      InvalidateCell( aCol, aRow );
    End;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
  ARow: Integer; var CanSelect: Boolean);
begin
  With Sender as TStringgrid Do
    If aCol = 1 Then
      Options := Options - [ goediting ]
    Else
      Options := Options + [ goediting ];
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  If Key = #32 Then
    With Sender As Tstringgrid Do
      If Col = 1 Then Begin
        ToggleCheckbox( Col, row );
        Key := #0;
      End;
end;

end.


[jesusr]

Here you have the conversion.

This is windows specific implementation, I think I could do a more portable solution by means of a TStringGrid derivate.

I noted the differences which I think are minimal, but I would like to get the real files, I mean the dfm and pas files to see the parameter naming differences. So I can improve the grids to be more delphi compliant.

If you can send the files please use this jesusrmx [at] yahoo . com . mx

regards.

Code: [Select]


unit unit1;

{$mode objfpc}{$H+}

interface

uses
  Windows, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
  Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure Form1Create(Sender: TObject);
    procedure Form1Destroy(Sender: TObject);
    procedure StringGrid1Click(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure StringGrid1KeyPress(Sender: TObject; var Key: char);
    procedure StringGrid1SelectCell(Sender: TObject; aCol, aRow: Integer;
      var CanSelect: Boolean);
  private
    { private declarations }
    FCheck, FNoCheck: TBitmap;
    procedure ToggleCheckbox(acol, arow: Integer);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

type
 TGridCracker = Class( TStringgrid );

{ TForm1 }

procedure TForm1.StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
  Rect: TRect; State: TGridDrawState);
var
 grid: TStringgrid;
begin
 If not ( gdFixed In State ) and (aCol = 1) Then Begin
  grid:= Sender As TStringgrid;
  With grid.Canvas Do Begin
   brush.color := $E0E0E0;
   // checkboxes look better on a non-white background
   Fillrect( rect );
   // listbox state is encoded by the Objects property
   If Assigned(grid.Objects[aCol, aRow]) Then
    Draw( (rect.right + rect.left - FCheck.width) div 2,
       (rect.bottom + rect.top - FCheck.height) div 2,
       FCheck )
   Else
    Draw( (rect.right + rect.left - FNoCheck.width) div 2,
       (rect.bottom + rect.top - FNoCheck.height) div 2,
       FNoCheck )
  End;
 End;
end;

procedure TForm1.Form1Create(Sender: TObject);
var
 bmp: TBitmap;
begin
 FCheck:= TBitmap.Create;
 FNoCheck:= TBitmap.Create;
 bmp:= TBitmap.create;
 try
  bmp.handle := LoadBitmap( 0, PChar(OBM_CHECKBOXES ));
  // bmp now has a 4x3 bitmap of divers state images
  // used by checkboxes and radiobuttons
  With FNoCheck Do Begin
   // the first subimage is the unchecked box
   width := bmp.width div 4;
   height := bmp.height div 3;
   canvas.copyrect( canvas.cliprect, bmp.canvas, canvas.cliprect );
  End;
  With FCheck Do Begin
   // the second subimage is the checked box
   width := bmp.width div 4;
   height := bmp.height div 3;
   canvas.copyrect(
    canvas.cliprect,
    bmp.canvas,
    rect( width, 0, 2*width, height ));
  End;
 finally
  bmp.free
 end;
end;

procedure TForm1.Form1Destroy(Sender: TObject);
begin
 FNoCheck.Free;
 FCheck.Free;
end;

procedure TForm1.StringGrid1Click(Sender: TObject);
var
 pt: TPoint;
 grid: TStringgrid;
 aCol, aRow: Integer;
begin
 GetCursorPos( pt );
 grid := Sender As TStringgrid;
 pt:= grid.ScreenToClient( pt );
 //grid.MouseToCell( pt.x, pt.y, aCol, aRow );
 pt := grid.MouseToCell(Pt);
 //If (aCol = 1) and (aRow >= grid.fixedRows) Then Begin
 If (Pt.x = 1) and (Pt.y >= grid.fixedRows) Then Begin
  // click landed in a checkbox cell
  //ToggleCheckbox( aCol, aRow );
  ToggleCheckbox( Pt.x, Pt.y );
 End;
end;

procedure TForm1.ToggleCheckbox(acol, arow: Integer);
begin
 If aCol = 1 Then
  With stringgrid1 Do Begin
   If Assigned( Objects[aCol, aRow] ) Then
    Objects[aCol, aRow] := Nil
   Else
    Objects[aCol, aRow] := TObject(1);
   TGridCracker(Stringgrid1).InvalidateCell( aCol, aRow);
  End;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; aCol, aRow: Integer;
  var CanSelect: Boolean);
begin
 With Sender as TStringgrid Do
  If aCol = 1 Then
   Options := Options - [ goediting ]
  Else
   Options := Options + [ goediting ];
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: char);
begin
 If Key = #32 Then
  With Sender As Tstringgrid Do
   If Col = 1 Then Begin
    ToggleCheckbox( Col, row );
    Key := #0;
   End;
end;


initialization
  {$I unit1.lrs}

end.


unit1.lrs:

{ This is an automatically generated lazarus resource file }

LazarusResources.Add('TForm1','FORMDATA',[
  'TPF0'#6'TForm1'#5'Form1'#7'Caption'#6#5'Form1'#12'ClientHeight'#3','#1#11'Cl'
  +'ientWidth'#3#144#1#8'OnCreate'#7#11'Form1Create'#9'OnDestroy'#7#12'Form1Des'
  +'troy'#13'PixelsPerInch'#2'`'#18'HorzScrollBar.Page'#3#145#1#18'VertScrollBa'
  +'r.Page'#3'-'#1#4'Left'#3'W'#1#6'Height'#3','#1#3'Top'#3#160#0#5'Width'#3#144
  +#1#0#11'TStringGrid'#11'StringGrid1'#5'Color'#7#7'clWhite'#8'ColCount'#2#5#15
  +'DefaultColWidth'#2'@'#16'DefaultRowHeight'#2#24#10'FixedColor'#7#9'clBtnFac'
  +'e'#13'GridLineWidth'#2#0#7'Options'#11#15'goFixedVertLine'#15'goFixedHorzLi'
  +'ne'#10'goVertLine'#10'goHorzLine'#13'goRangeSelect'#14'goSmoothScroll'#0#8
  +'RowCount'#2#5#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#0#7'TabStop'#9
  +#15'VisibleColCount'#2#4#15'VisibleRowCount'#2#4#7'OnClick'#7#16'StringGrid1'
  +'Click'#10'OnDrawCell'#7#19'StringGrid1DrawCell'#10'OnKeyPress'#7#19'StringG'
  +'rid1KeyPress'#12'OnSelectCell'#7#21'StringGrid1SelectCell'#4'Left'#2#21#6'H'
  +'eight'#3#211#0#3'Top'#2#13#5'Width'#3'm'#1#9'ColWidths'#1#2'@'#2'@'#2'@'#2
  +'@'#2'@'#0#10'RowHeights'#1#2#24#2#24#2#24#2#24#2#24#0#5'Cells'#1#2#0#0#0#0#0
]);



[NelsonN]

I noted the differences which I think are minimal, but I would like to get the real files, I mean the dfm and pas files to see the parameter naming differences. So I can improve the grids to be more delphi compliant.

If you can send the files please use this jesusrmx [at] yahoo . com . mx

Thanks a lot!

I have two questions.

I just compiled your code and the checkboxes are filled in grey when checked, not a check. Is this the way it's suppose to look? I am running Lazarus in Windows XP.

If I understand your request, you want me to compile the Borland code in Delphi and send you the .dfm and .pas files?

Again, thank you very much!

[jesusr]

I have two questions.

I just compiled your code and the checkboxes are filled in grey when checked, not a check. Is this the way it's suppose to look? I am running Lazarus in Windows XP.

I'm running win98 here and I saw filled/unfilled checkboxes too. I thought that it was supposed to be that way, almost all the code was unmodified!.

I tried to save the bitmap for close inspection but it didn't work, it could be a TBitmap problem I think.

If I understand your request, you want me to compile the Borland code in Delphi and send you the .dfm and .pas files?

Again, thank you very much!

Don't worry I dont need them.

[jesusr]

Now I know what happen, the canvas.ClipRect method doesn't work!

do the following changes to get the desired effect:

Code: [Select]


  With FNoCheck Do Begin
   // the first subimage is the unchecked box
   width := bmp.width div 4;
   height := bmp.height div 3;
   canvas.copyrect(
    rect( 0, 0, width, height ),
    bmp.canvas,
    rect( 0, 0, width, height )
   );
  End;
  With FCheck Do Begin
   // the second subimage is the checked box
   width := bmp.width div 4;
   height := bmp.height div 3;
   canvas.copyrect(
    rect( 0, 0, width, height ),
    bmp.canvas,
    rect( width, 0, 2*width, height ));
  End;
 


[NelsonN]

If you change the brush color to white as I did in my project, the checkbox cell looks much better.

brush.color := $FFFFFF;

[NelsonN]

jesusr, I just visted your website.

Your working on grids. Does your Grid component have features like checkboxes, or are you planning to work those in?

[jesusr]

jesusr, I just visted your website.

Your working on grids. Does your Grid component have features like checkboxes, or are you planning to work those in?

The grids I was working on are now the Lazarus TStringGrid and TDrawGrid.

The features avalilable, with some exceptions, are basically the same features you will find in delphi's grids (from the component user point of view) so no checkboxes or so.

I'm not planning do add new features to the standard TStringGrid, indeed I'm still working on improving compatibility with delphi's grids, so I think for adding new functionality is better to use a new component.

I'm not sure about creating new derivated TStringGrid but if I ever do it, I would like to add checkbox functionality in a portable way.

Certainly, I wish to have this feature in a DbGrid, so editing boolean fields would be as simple as clicking the cell

[Anonymous]

Here you have the conversion.

This is windows specific implementation, I think I could do a more portable solution by means of a TStringGrid derivate.

I noted the differences which I think are minimal, but I would like to get the real files, I mean the dfm and pas files to see the parameter naming differences. So I can improve the grids to be more delphi compliant.

If you can send the files please use this jesusrmx [at] yahoo . com . mx

regards.

Code: [Select]


unit unit1;

{$mode objfpc}{$H+}

interface

uses
  Windows, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
  Grids;

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure Form1Create(Sender: TObject);
    procedure Form1Destroy(Sender: TObject);
    procedure StringGrid1Click(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure StringGrid1KeyPress(Sender: TObject; var Key: char);
    procedure StringGrid1SelectCell(Sender: TObject; aCol, aRow: Integer;
      var CanSelect: Boolean);
  private
    { private declarations }
    FCheck, FNoCheck: TBitmap;
    procedure ToggleCheckbox(acol, arow: Integer);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

type
 TGridCracker = Class( TStringgrid );

{ TForm1 }

procedure TForm1.StringGrid1DrawCell(Sender: TObject; aCol, aRow: Integer;
  Rect: TRect; State: TGridDrawState);
var
 grid: TStringgrid;
begin
 If not ( gdFixed In State ) and (aCol = 1) Then Begin
  grid:= Sender As TStringgrid;
  With grid.Canvas Do Begin
   brush.color := $E0E0E0;
   // checkboxes look better on a non-white background
   Fillrect( rect );
   // listbox state is encoded by the Objects property
   If Assigned(grid.Objects[aCol, aRow]) Then
    Draw( (rect.right + rect.left - FCheck.width) div 2,
       (rect.bottom + rect.top - FCheck.height) div 2,
       FCheck )
   Else
    Draw( (rect.right + rect.left - FNoCheck.width) div 2,
       (rect.bottom + rect.top - FNoCheck.height) div 2,
       FNoCheck )
  End;
 End;
end;

procedure TForm1.Form1Create(Sender: TObject);
var
 bmp: TBitmap;
begin
 FCheck:= TBitmap.Create;
 FNoCheck:= TBitmap.Create;
 bmp:= TBitmap.create;
 try
  bmp.handle := LoadBitmap( 0, PChar(OBM_CHECKBOXES ));
  // bmp now has a 4x3 bitmap of divers state images
  // used by checkboxes and radiobuttons
  With FNoCheck Do Begin
   // the first subimage is the unchecked box
   width := bmp.width div 4;
   height := bmp.height div 3;
   canvas.copyrect( canvas.cliprect, bmp.canvas, canvas.cliprect );
  End;
  With FCheck Do Begin
   // the second subimage is the checked box
   width := bmp.width div 4;
   height := bmp.height div 3;
   canvas.copyrect(
    canvas.cliprect,
    bmp.canvas,
    rect( width, 0, 2*width, height ));
  End;
 finally
  bmp.free
 end;
end;

procedure TForm1.Form1Destroy(Sender: TObject);
begin
 FNoCheck.Free;
 FCheck.Free;
end;

procedure TForm1.StringGrid1Click(Sender: TObject);
var
 pt: TPoint;
 grid: TStringgrid;
 aCol, aRow: Integer;
begin
 GetCursorPos( pt );
 grid := Sender As TStringgrid;
 pt:= grid.ScreenToClient( pt );
 //grid.MouseToCell( pt.x, pt.y, aCol, aRow );
 pt := grid.MouseToCell(Pt);
 //If (aCol = 1) and (aRow >= grid.fixedRows) Then Begin
 If (Pt.x = 1) and (Pt.y >= grid.fixedRows) Then Begin
  // click landed in a checkbox cell
  //ToggleCheckbox( aCol, aRow );
  ToggleCheckbox( Pt.x, Pt.y );
 End;
end;

procedure TForm1.ToggleCheckbox(acol, arow: Integer);
begin
 If aCol = 1 Then
  With stringgrid1 Do Begin
   If Assigned( Objects[aCol, aRow] ) Then
    Objects[aCol, aRow] := Nil
   Else
    Objects[aCol, aRow] := TObject(1);
   TGridCracker(Stringgrid1).InvalidateCell( aCol, aRow);
  End;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; aCol, aRow: Integer;
  var CanSelect: Boolean);
begin
 With Sender as TStringgrid Do
  If aCol = 1 Then
   Options := Options - [ goediting ]
  Else
   Options := Options + [ goediting ];
end;

procedure TForm1.StringGrid1KeyPress(Sender: TObject; var Key: char);
begin
 If Key = #32 Then
  With Sender As Tstringgrid Do
   If Col = 1 Then Begin
    ToggleCheckbox( Col, row );
    Key := #0;
   End;
end;


initialization
  {$I unit1.lrs}

end.


unit1.lrs:

{ This is an automatically generated lazarus resource file }

LazarusResources.Add('TForm1','FORMDATA',[
  'TPF0'#6'TForm1'#5'Form1'#7'Caption'#6#5'Form1'#12'ClientHeight'#3','#1#11'Cl'
  +'ientWidth'#3#144#1#8'OnCreate'#7#11'Form1Create'#9'OnDestroy'#7#12'Form1Des'
  +'troy'#13'PixelsPerInch'#2'`'#18'HorzScrollBar.Page'#3#145#1#18'VertScrollBa'
  +'r.Page'#3'-'#1#4'Left'#3'W'#1#6'Height'#3','#1#3'Top'#3#160#0#5'Width'#3#144
  +#1#0#11'TStringGrid'#11'StringGrid1'#5'Color'#7#7'clWhite'#8'ColCount'#2#5#15
  +'DefaultColWidth'#2'@'#16'DefaultRowHeight'#2#24#10'FixedColor'#7#9'clBtnFac'
  +'e'#13'GridLineWidth'#2#0#7'Options'#11#15'goFixedVertLine'#15'goFixedHorzLi'
  +'ne'#10'goVertLine'#10'goHorzLine'#13'goRangeSelect'#14'goSmoothScroll'#0#8
  +'RowCount'#2#5#10'ScrollBars'#7#10'ssAutoBoth'#8'TabOrder'#2#0#7'TabStop'#9
  +#15'VisibleColCount'#2#4#15'VisibleRowCount'#2#4#7'OnClick'#7#16'StringGrid1'
  +'Click'#10'OnDrawCell'#7#19'StringGrid1DrawCell'#10'OnKeyPress'#7#19'StringG'
  +'rid1KeyPress'#12'OnSelectCell'#7#21'StringGrid1SelectCell'#4'Left'#2#21#6'H'
  +'eight'#3#211#0#3'Top'#2#13#5'Width'#3'm'#1#9'ColWidths'#1#2'@'#2'@'#2'@'#2
  +'@'#2'@'#0#10'RowHeights'#1#2#24#2#24#2#24#2#24#2#24#0#5'Cells'#1#2#0#0#0#0#0
]);



[asdf]

  I tried but nothing happened only a sleeping TStringGrid on a TForm.
Maybe there must be a lot to change, help me please ..

[nicke85]

I have tried that code because also need to put checkbox into stringrid columns eg.
StringGrid1.Cells[0,i] from for-downto loop.
Code is not good in fpc 2.5.1 and lazarus 0.9.31svn.
always got error that StringGrid1.VisibleColCount in read-only..
Does anybody have some solution!?

[Blaazen]

This thread {and code} is about conversion from Delphi to Lazarus.

Standart way of Lazarus is:
Put TStringGrid on form,
Create Column(s)
Set column(s) property ButtonStyle to cbsCheckBoxColumn

[nicke85]

So easy I like Lazarus
Thanx Blaazen
I see now that in DBGrid is the same ability for that
How can enable fields to be true and false editable!?

[Zoran]

You can read these two tutorials about using grids in Lazarus:

http://lazarus-ccr.sourceforge.net/docs/lcl/grids/howtousegrids.html
http://wiki.lazarus.freepascal.org/Grids_Reference_Page

[nicke85]

This is what I was looking for