// -----------------------------------------------------------------------------
//  TRVGrid, v1.3 (formerly TBCGrid)
//  © 2003, Dmitry 'Creator' Bobrik / BC software development
// -----------------------------------------------------------------------------

//
//  Special for MNC 1.5.x.x project
//  Tested with Delphi 5
//

//
// SOME CODE COMMENTS:
//
//  grid lines are drawn at the right & bottom edges of cells,
//  so the actual cell width is "internal" cell width + grid width,
//  the same for height
//
//  you can add a multisize cells easily, just create a descendant of TRVGrid
//  and override the GetRowBegin and GetColBegin methods. they are the only
//  methods used to determine cell and grid coordinates.
//
//  you may also override the Resize procedure to set your own method of
//  determining the entire control bounds.
//

{NOT$DEFINE DONTUSEVERTICALSCROLL}

unit RVGrids;

interface

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

type
  TRVGridDrawEvent = procedure (Sender: TObject; ACol, ARow: Integer; ARect: TRect; Selected: Boolean) of object;
  TRVGridBoundsType = (bbtByCellBounds, bbtByGridBounds);

  TRVCustomGrid = class(TCustomControl)
  private
    { Private declarations }
    FRow,
    FCol: Integer;               // currently selected (absolute)
    FFirstRow: Integer;          // scrolled to this - first visible row
    FRows,
    FCols: Integer;              // total number of rows/cols
    FRowsVisible: Integer;       // number of visible rows (set by user)
    // metrics
    FGridLineWidth: Integer;     // width of grid lines
    FColWidth,
    FRowHeight: Integer;         // bounds ;-)
    // visuals
    FGridLineColor: TColor;
    FBorderStyle: TBorderStyle;
    FBoundsType: TRVGridBoundsType;
    // internal
    FWCol,
    FHRow: Integer;              // counted width and height * 1000
    // events
    FOnDrawCell: TRVGridDrawEvent;
    FOnSelectCell: TNotifyEvent;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    FOnTopLeftChanged: TNotifyEvent;
    {$ENDIF}
    // procedures
    procedure SetRows(const Value: Integer);
    procedure SetCols(const Value: Integer);
    procedure SetGridLineColor(const Value: TColor);
    {$IFNDEF DONTUSEVERTICALSCROLL}
    procedure SetRowsVisible(const Value: Integer);
    {$ENDIF}
    procedure SetGridLineWidth(const Value: Integer);
    procedure SetBorderStyle(const Value: TBorderStyle);
    procedure SetBoundsType(const Value: TRVGridBoundsType);
    procedure SetColWidth(const Value: Integer);
    procedure SetRowHeight(const Value: Integer);
    procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    procedure WMVScroll( var Msg: TWMVScroll ); message WM_VSCROLL;
    {$ENDIF}
    procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
  protected
    { Protected declarations }
    procedure Initalize; virtual;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Loaded; override;
    procedure Resize; override;
    procedure Paint; override;
    procedure DrawGrid; virtual;
    procedure DrawCell(ACol, ARow: Integer; ARect: TRect; ASelected: Boolean); virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    {$ENDIF}
    procedure KeyDown( var Key: Word; Shift: TShiftState ); override;
    procedure UpdateScrollPos;
    procedure UpdateScrollRange;
    procedure DoSelectCell; virtual;
    procedure DoTopLeftChanged; virtual;

    // to be published
    property Row: Integer read FRow;   // yes, it is read only! use SelectCell to select some cell runtime!
    property Col: Integer read FCol;
    property RowCount: Integer read FRows write SetRows;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    property RowsVisible: Integer read FRowsVisible write SetRowsVisible;
    {$ENDIF}
    property ColCount: Integer read FCols write SetCols;
    property DefaultColWidth: Integer read FColWidth write SetColWidth;
    property DefaultRowHeight: Integer read FRowHeight write SetRowHeight;
    property GridLineColor: TColor read FGridLineColor write SetGridLineColor;
    property GridLineWidth: Integer read FGridLineWidth write SetGridLineWidth;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property BoundsType: TRVGridBoundsType read FBoundsType write SetBoundsType default bbtByCellBounds;
    // events
    property OnDrawCell: TRVGridDrawEvent read FOnDrawCell write FOnDrawCell;
    property OnSelectCell: TNotifyEvent read FOnSelectCell write FOnSelectCell;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    property OnTopLeftChanged: TNotifyEvent read FOnTopLeftChanged write FOnTopLeftChanged;
    {$ENDIF}
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    //
    function GetColBegin(ACol: integer): Integer; // return the X-coordinate of column begin
    function GetRowBegin(ARow: Integer): Integer; virtual; // to make rows different with in descendants
    function GetCellRect(ACol, ARow: Integer): TRect; // return the cell rect (EXCLUDING the border)
    function GetColAt(X: Integer): Integer;
    function GetRowAt(Y: Integer): Integer;
    //
    function SelectCell(ACol, ARow: Longint): Boolean; virtual;

    property Canvas;
  published
    { Published declarations }
  end;

  TRVGrid = class(TRVCustomGrid)
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property Ctl3D;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property ParentBiDiMode;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property Color default clWindow;
//    property ScrollBars default [sbHorz,sbVert];
//    property BorderStyle default bsSingle;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnStartDock;
    property OnStartDrag;
    // special
    property BorderStyle;
    property BoundsType;
    property RowCount;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    property RowsVisible;
    {$ENDIF}
    property ColCount;
    property GridLineColor;
    property GridLineWidth;
    property DefaultColWidth;
    property DefaultRowHeight;
    property Row;
    property Col;
    // events
    property OnDrawCell;
    property OnSelectCell;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    property OnTopLeftChanged;
    {$ENDIF}
  end;

implementation

uses Math; // Max() function

{ TRVCustomGrid }

constructor TRVCustomGrid.Create(AOwner: TComponent);
begin
  inherited;
  Color := clWindow;
  ParentColor := False;
  TabStop := True;
  FBorderStyle := bsSingle;
  SetBounds(Left, Top, 100, 100);
  DoubleBuffered := True;
  Initalize;
end;

procedure TRVCustomGrid.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or WS_TABSTOP;
    {$IFNDEF DONTUSEVERTICALSCROLL}
    if (FRowsVisible < FRows) then  // not always scrollable, v1.2
      Style := Style or WS_VSCROLL;
    {$ENDIF}
    WindowClass.style := CS_DBLCLKS;
    if FBorderStyle = bsSingle then
      ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  end;
end;

procedure TRVCustomGrid.Loaded;
begin
  inherited;
  Resize;
  //UpdateScrollRange;
end;

procedure TRVCustomGrid.Resize;
begin
  if FBoundsType = bbtByCellBounds then
  begin
    // Calculate grid bounds by defined cell bounds and grid width
    //
    ClientWidth := (FColWidth + FGridLineWidth) * FCols - FGridLineWidth;
    ClientHeight := (FRowHeight + FGridLineWidth) * FRowsVisible - FGridLineWidth;
  end
  else
  begin
    // Calculate cell width and height in a kind of floating point :)
    //
    FWCol := MulDiv((ClientWidth - Pred(FCols) * FGridLineWidth), 1000, FCols);
    FHRow := MulDiv((ClientHeight - Pred(FRowsVisible) * FGridLineWidth), 1000, FRowsVisible);
  end;
  UpdateScrollRange;
  inherited;
  Repaint;
end;

procedure TRVCustomGrid.Initalize;
begin
  FRow := 0;
  FCol := 0;
  FFirstRow := 0;
  FRows := 10;
  FCols := 10;
  FRowsVisible := 10;
  FRowHeight := 16;
  FColWidth := 16;
  FGridLineWidth := 1;
  FGridLineColor := clScrollBar;
  FBoundsType := bbtByCellBounds;
end;

procedure TRVCustomGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if (ssLeft in Shift) then
    MouseDown(mbLeft, Shift, X, Y);
end;

procedure TRVCustomGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  ARow, ACol: Integer;
begin
  inherited;
  if not Focused and CanFocus then
    SetFocus;
  // Now selecting the clicked...
  if Button = mbLeft then  // v1.3 - w/o full repaint is MUCH faster!
  begin
    ACol := FCol;
    ARow := FRow;
    if SelectCell(GetColAt(X), GetRowAt(Y)) then
    begin
      DrawCell(ACol, ARow, GetCellRect(ACol, ARow), False);
      DrawCell(FCol, FRow, GetCellRect(FCol, FRow), True);
    end;
  end;
end;

procedure TRVCustomGrid.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  case Key of
    VK_UP:
      SelectCell(FCol, Pred(FRow));
    VK_DOWN:
      SelectCell(FCol, Succ(FRow));
    VK_LEFT:
      SelectCell(Pred(FCol), FRow);
    VK_RIGHT:
      SelectCell(Succ(FCol), FRow);
    VK_HOME:
      if (Shift = [ssCtrl]) then
        SelectCell(0, 0)
      else
        SelectCell(0, FRow);
    VK_END:
      if (Shift = [ssCtrl]) then
        SelectCell(Pred(FCols), Pred(FRows))
      else
        SelectCell(Pred(FCols), FRow);
    VK_PRIOR:
        SelectCell(FCol, 0);
    VK_NEXT:
        SelectCell(FCol, Pred(FRows));
  end;
  Repaint;
end;

function TRVCustomGrid.GetColBegin(ACol: integer): Integer;
begin
 if FBoundsType = bbtByCellBounds then
   Result := ACol * (FColWidth + FGridLineWidth)
 else
   Result := (ACol * (FWCol + FGridLineWidth * 1000)) div 1000;
end;

function TRVCustomGrid.GetRowBegin(ARow: Integer): Integer;
begin
 if FBoundsType = bbtByCellBounds then
   Result := (ARow - FFirstRow) * (FRowHeight + FGridLineWidth)
 else
   Result := ((ARow - FFirstRow) * (FHRow + FGridLineWidth * 1000)) div 1000;
end;

function TRVCustomGrid.GetCellRect(ACol, ARow: Integer): TRect;
begin
  Result.Left := GetColBegin(ACol);
  Result.Top := GetRowBegin(ARow);
  Result.Right := GetColBegin(ACol + 1) - FGridLineWidth;
  Result.Bottom := GetRowBegin(ARow + 1) - FGridLineWidth;
end;

function TRVCustomGrid.GetColAt(X: Integer): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to FCols do
    if X > GetColBegin(i) then
      Result := i
    else
      Break;
end;

function TRVCustomGrid.GetRowAt(Y: Integer): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := Pred(FFirstRow) to FFirstRow + FRowsVisible do
    if Y > GetRowBegin(i) then
      Result := i
    else
      Break;
end;

procedure TRVCustomGrid.Paint;
var
  i, j: Integer;
  ARect: TRect;
begin
  Canvas.Font.Assign(Font);

  if FGridLineWidth > 0 then
    DrawGrid;
  for i := 0 to Pred(FCols) do
    for j := FFirstRow to Pred(FFirstRow + FRowsVisible) do
    begin
      ARect := GetCellRect(i, j);
      DrawCell(i, j, ARect, (i = FCol) and (j = FRow));
    end;
end;

procedure TRVCustomGrid.DrawGrid;
var
  i: Integer;
  HStep, VStep: Integer;
begin
  Canvas.Pen.Color := FGridLineColor;
  Canvas.Pen.Width := FGridLineWidth;
  Canvas.Pen.Style := psSolid;

  for i := 1 to Pred(FCols) do
  begin
    HStep := GetColBegin(i) - Succ(FGridLineWidth) div 2;
    Canvas.MoveTo(HStep, 0);
    Canvas.LineTo(HStep, Self.ClientHeight);
  end;

  for i := Succ(FFirstRow) to Pred(FFirstRow + FRowsVisible) do
  begin
    VStep := GetRowBegin(i) - Succ(FGridLineWidth) div 2;
    Canvas.MoveTo(0, VStep);
    Canvas.LineTo(ClientWidth, VStep);
  end;
end;

procedure TRVCustomGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; ASelected: Boolean);
begin
  if ASelected then
  begin
    Canvas.Brush.Color := clHighlight;
    Canvas.Font.Color := clHighlightText;
  end
  else
  begin
    Canvas.Brush.Color := Color;
    Canvas.Font.Color := Font.Color; // bug fix, v1.1
  end;
  // Canvas.FillRect(ARect);  // TODO: should we clear the cell before repaint ???
  if Assigned(FOnDrawCell) then
    FOnDrawCell(Self, ACol, ARow, ARect, ASelected);
end;

function TRVCustomGrid.SelectCell(ACol, ARow: Integer): Boolean;
begin
  Result := True;
  if (ACol >= 0) and (ACol < FCols) then
    FCol := ACol
  else
    Result := False;

  if (ARow >= 0) and (ARow < FRows) then
    FRow := ARow
  else
    Result := False;

  {$IFNDEF DONTUSEVERTICALSCROLL}
  if (FRow >= FFirstRow + FRowsVisible) or (FRow < FFirstRow) then
  begin
    if (FRow < FFirstRow) then
      FFirstRow := FRow
    else
      FFirstRow := Max(FRow - FRowsVisible + 1, 0);
    UpdateScrollPos;
  end;
  {$ENDIF}

  DoSelectCell;
end;

procedure TRVCustomGrid.SetCols(const Value: Integer);
begin
  if Value <= 0 then
    raise EAssertionFailed.CreateFmt('Incorrect ColCount value %d', [Value]);
  FCols := Value;
  Resize;
end;

procedure TRVCustomGrid.SetGridLineColor(const Value: TColor);
begin
  FGridLineColor := Value;
  Repaint;
end;

procedure TRVCustomGrid.SetGridLineWidth(const Value: Integer);
begin
  FGridLineWidth := Value;
  Resize;
end;

procedure TRVCustomGrid.SetRows(const Value: Integer);
begin
  if Value <= 0 then
    raise EAssertionFailed.CreateFmt('Incorrect RowCount value %d', [Value]);
  FRows := Value;
  {$IFDEF DONTUSEVERTICALSCROLL}
  FRowsVisible := Value;
  {$ENDIF}
  FFirstRow := 0;
  Resize;
end;

{$IFNDEF DONTUSEVERTICALSCROLL}
procedure TRVCustomGrid.SetRowsVisible(const Value: Integer);
begin
  FFirstRow := 0;
  if Value <= 0 then
    raise EAssertionFailed.CreateFmt('Incorrect RowsVisible value %d', [Value]);
  if ((FRows < Value) and (FRowsVisible < FRows)) or
     ((FRows > Value) and (FRowsVisible >= FRows)) then
     begin
       FRowsVisible := Value;
       RecreateWnd;
       UpdateScrollRange;
     end
     else
     begin
       FRowsVisible := Value;
       Resize;
     end;
end;
{$ENDIF}

procedure TRVCustomGrid.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
  Msg.Result := DLGC_WANTARROWS;
end;

procedure TRVCustomGrid.WMSize(var Msg: TWMSize);
begin
  inherited;
end;

procedure TRVCustomGrid.CMShowingChanged(var Message: TMessage);
begin
  inherited;
  if Showing then
    UpdateScrollRange;
end;

{$IFNDEF DONTUSEVERTICALSCROLL}
procedure TRVCustomGrid.WMVScroll(var Msg: TWMVScroll);
var
  Info: SCROLLINFO;
begin
  if Visible and CanFocus and TabStop then
    SetFocus;
  case Msg.ScrollCode of
    SB_LINEUP:
      if FFirstRow > 0 then
        Dec(FFirstRow);
    SB_LINEDOWN:
      if FFirstRow < FRows - FRowsVisible then
        Inc(FFirstRow);
    SB_PAGEUP:
      if FFirstRow > FRowsVisible then
        Dec(FFirstRow, FRowsVisible)
      else
        FFirstRow := 0;
    SB_PAGEDOWN:
      if FFirstRow < FRows - FRowsVisible then
        Inc(FFirstRow, FRowsVisible)
      else
        FFirstRow := FRows - FRowsVisible;
    SB_THUMBPOSITION, SB_THUMBTRACK:
      begin
        with Info do
        begin
          cbSize := SizeOf(SCROLLINFO);
          fMask := SIF_TRACKPOS;
        end;
        GetScrollInfo(Handle, SB_VERT, Info);
        FFirstRow := Info.nTrackPos;
      end;
    SB_BOTTOM:
      FFirstRow := FRows - FRowsVisible;
    SB_TOP:
      FFirstRow := 0;
  end;
  UpdateScrollPos;
  DoTopLeftChanged;
end;
{$ENDIF}

procedure TRVCustomGrid.SetBorderStyle(const Value: TBorderStyle);
begin
  FBorderStyle := Value;
  RecreateWnd;
end;

procedure TRVCustomGrid.SetBoundsType(const Value: TRVGridBoundsType);
begin
  FBoundsType := Value;
  Resize;
end;

procedure TRVCustomGrid.SetColWidth(const Value: Integer);
begin
  FColWidth := Value;
  Resize;
end;

procedure TRVCustomGrid.SetRowHeight(const Value: Integer);
begin
  FRowHeight := Value;
  Resize;
end;

{$IFNDEF DONTUSEVERTICALSCROLL}
function TRVCustomGrid.DoMouseWheelDown(Shift: TShiftState;
  MousePos: TPoint): Boolean;
begin
  Result := inherited DoMouseWheelDown(Shift, MousePos);
  if not Result then
    if FFirstRow < FRows - FRowsVisible then
    begin
      Inc(FFirstRow);
      UpdateScrollPos;
      DoTopLeftChanged;
      Result := True;
    end;
end;

function TRVCustomGrid.DoMouseWheelUp(Shift: TShiftState;
  MousePos: TPoint): Boolean;
begin
  Result := inherited DoMouseWheelUp(Shift, MousePos);
  if not Result then
    if FFirstRow > 0 then
    begin
      Dec(FFirstRow);
      UpdateScrollPos;
      DoTopLeftChanged;
      Result := True;
    end;
end;
{$ENDIF}

procedure TRVCustomGrid.UpdateScrollPos;
begin
  {$IFNDEF DONTUSEVERTICALSCROLL}
//  if HandleAllocated then
    SetScrollPos(Handle, SB_VERT, FFirstRow, True);
  {$ENDIF}
  Repaint;
end;

procedure TRVCustomGrid.DoSelectCell;
begin
 if Assigned(FOnSelectCell) then
   FOnSelectCell(Self);
end;

procedure TRVCustomGrid.UpdateScrollRange; //v1.2
{$IFNDEF DONTUSEVERTICALSCROLL}
var
  Info: SCROLLINFO;
{$ENDIF}
begin
  {$IFNDEF DONTUSEVERTICALSCROLL}
  if HandleAllocated then
  begin
    Info.cbSize := SizeOf(SCROLLINFO);
    Info.fMask := SIF_RANGE or SIF_POS;
    Info.nMin := 0;
    Info.nPos := 0;
    if FRowsVisible < FRows then
    begin
      Info.fMask := Info.fMask or SIF_PAGE;
      Info.nPage := FRowsVisible;
      Info.nMax := FRows - 1;
    end else
      Info.nMax := 0;
    SetScrollInfo(Handle, SB_VERT, Info, False);
    UpdateScrollPos;
    Perform(WM_NCPAINT, 1, 0); // workaround - bug with theming scrollbar arrows, v1.1
  end;
  {$ENDIF}
end;

procedure TRVCustomGrid.DoTopLeftChanged; //v1.1
begin
  if Row < FFirstRow then
    SelectCell(-1, FFirstRow)
  else
    if Row > Pred(FFirstRow + FRowsVisible) then
      SelectCell(-1, Pred(FFirstRow + FRowsVisible));
  if Assigned(FOnTopLeftChanged) then
    FOnTopLeftChanged(Self);
end;

end.
