CustomViewClass.pas

   1 unit CustomViewClass;
   2
   3 interface
   4
   5 uses
   6   ConstantsClass, CustomStringGridClass, HardwareClass, ResourcesClass,
   7   TypesClass,
   8   Classes, Controls, Graphics, Grids, StdCtrls, Types;
   9
  10 type
  11
  12   { TCustomView }
  13
  14   TCustomView = class(TCustomStringGrid)
  15   private
  16     pChanges: array of array of Boolean;
  17     pColorTheme: TViewTheme;
  18     pHardware: THardware;
  19     pOldOnOperand, pOldOnState, pOnOperand, pOnState: TChangeEvent;
  20     function pGetChanges(ACol, ARow: Integer): Boolean; virtual;
  21     function pGetColCount: Longint; virtual;
  22     function pGetRowCount: Longint; virtual;
  23     procedure pCustomDblClick(Sender: TObject); virtual;
  24     procedure pCustomDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); virtual;
  25     procedure pCustomMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual;
  26     procedure pDrawSingleCell(Canvas: TCanvas; ACol, ARow: Integer; Rect: TRect; Colors: TColors); virtual;
  27     procedure pOnOperandProc(Sender: TObject); virtual;
  28     procedure pOnSelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); virtual;
  29     procedure pOnStateProc(Sender: TObject); virtual;
  30     procedure pSetChanges(ACol, ARow: Integer; Change: Boolean); virtual;
  31     procedure pSetColorTheme(ColorTheme: TViewTheme); virtual;
  32     procedure pSetColCount(Count: Integer); virtual;
  33     procedure pSetHardware(Input: THardware); virtual;
  34     procedure pSetRowCount(Count: Integer); virtual;
  35   public
  36     constructor CreateView(AOwner: TComponent; Hw: THardware); virtual;
  37     destructor Destroy; override;
  38     property Changes[ACol, ARow: Integer]: Boolean read pGetChanges write pSetChanges;
  39     property ColorTheme: TViewTheme read pColorTheme write pSetColorTheme;
  40     property ColCount: Longint read pGetColCount write pSetColCount;
  41     property Hardware: THardware read pHardware write pSetHardware;
  42     property OnOperand: TChangeEvent read pOnOperand write pOnOperand;
  43     property OnState: TChangeEvent read pOnState write pOnState;
  44     property RowCount: Longint read pGetRowCount write pSetRowCount;
  45   end;
  46
  47 implementation
  48
  49 // ************************************************************************** //
  50 // *                       TCustomView implementation                       * //
  51 // ************************************************************************** //
  52
  53   function TCustomView.pGetChanges(ACol, ARow: Integer): Boolean;
  54   begin
  55     Result := False;
  56     if (ACol < 0) or not(ACol < ColCount) then Exit;
  57     if (ARow < 0) or not(ARow < RowCount) then Exit;
  58     Result := pChanges[ACol, ARow];
  59   end;
  60
  61   function TCustomView.pGetColCount: Longint;
  62   begin
  63     Result := inherited ColCount;
  64   end;
  65
  66   function TCustomView.pGetRowCount: Longint;
  67   begin
  68     Result := inherited RowCount;
  69   end;
  70
  71   procedure TCustomView.pCustomDblClick(Sender: TObject);
  72   var
  73     lkey: Word;
  74   begin
  75     lkey := KEY_RETURN;
  76     OnKeyDown(Self, lkey, []);
  77   end;
  78
  79   procedure TCustomView.pCustomDrawCell(Sender: TObject; ACol, ARow: Integer;
  80     Rect: TRect; State: TGridDrawState);
  81   begin
  82     if (gdSelected in State) and Selected then
  83       pDrawSingleCell(Canvas, ACol, ARow, Rect, ColorTheme.Line.Selected)
  84     else
  85       pDrawSingleCell(Canvas, ACol, ARow, Rect, ColorTheme.Line.None)
  86   end;
  87
  88   procedure TCustomView.pCustomMouseDown(Sender: TObject; Button: TMouseButton;
  89     Shift: TShiftState; X, Y: Integer);
  90   var
  91     lcol, lrow: Integer;
  92     lselect: TGridRect;
  93   begin
  94     MouseToCell(X, Y, lcol, lrow);
  95     if SelectCell(lcol, lrow) then
  96     {$IFDEF UNIX}
  97       SetColRow(1, 0);
  98     // Lazarus is really nice, by having incompatible calls :-(
  99     {$ELSE}
 100     begin
 101       lselect.Top := lrow;
 102       lselect.Bottom := lrow;
 103       lselect.Left := lcol;
 104       lselect.Right := lcol;
 105       Selection := lselect;
 106     end;
 107     {$ENDIF}
 108   end;
 109
 110   procedure TCustomView.pDrawSingleCell(Canvas: TCanvas; ACol, ARow: Integer;
 111     Rect: TRect; Colors: TColors);
 112   var
 113     lsize: TSize;
 114     lx, ly: Integer;
 115   begin
 116     with Rect do
 117     begin
 118       Canvas.Brush.Color := Colors.BG;
 119       if Changes[ACol, ARow] then Canvas.Font.Color := ColorTheme.Change
 120       else Canvas.Font.Color := Colors.FG;
 121       lsize := Canvas.TextExtent(Cells[ACol, ARow]);
 122       lx := (Right - Left - lsize.cx) div 2 + Left;
 123       ly := (Bottom - Top - lsize.cy) div 2 + Top;
 124       Canvas.FillRect(Rect);
 125       Canvas.TextOut(lx, ly, Cells[ACol, ARow]);
 126     end;
 127   end;
 128
 129   procedure TCustomView.pOnOperandProc(Sender: TObject);
 130   begin
 131     if not(@pOnOperand = nil) then pOnOperand(Sender);
 132     Repaint;
 133     if not(@pOldOnOperand = nil) then pOldOnOperand(Sender);
 134   end;
 135
 136   procedure TCustomView.pOnSelectCell(Sender: TObject; ACol, ARow: Integer;
 137     var CanSelect: Boolean);
 138   begin
 139     CanSelect := not(ACol = 0);
 140   end;
 141
 142   procedure TCustomView.pOnStateProc(Sender: TObject);
 143   begin
 144     if not(@pOnState = nil) then pOnState(Sender);
 145     Repaint;
 146     if not(@pOldOnState = nil) then pOldOnState(Sender);
 147   end;
 148
 149   procedure TCustomView.pSetChanges(ACol, ARow: Integer; Change: Boolean);
 150   begin
 151     if (ACol < 0) or not(ACol < ColCount) then Exit;
 152     if (ARow < 0) or not(ARow < RowCount) then Exit;
 153     pChanges[ACol, ARow] := Change;
 154   end;
 155
 156   procedure TCustomView.pSetColorTheme(ColorTheme: TViewTheme);
 157   begin
 158     pColorTheme := ColorTheme;
 159     Color := ColorTheme.Line.None.BG;
 160   end;
 161
 162   procedure TCustomView.pSetColCount(Count: Integer);
 163   var
 164     i: Integer;
 165   begin
 166     inherited ColCount := Count;
 167     SetLength(pChanges, inherited ColCount);
 168     for i := 0 to (ColCount - 1) do
 169         SetLength(pChanges[i], inherited RowCount);
 170   end;
 171
 172   procedure TCustomView.pSetHardware(Input: THardware);
 173   begin
 174     if not(pHardware = nil) then pHardware.OnState := pOldOnState;
 175     pHardware := Input;
 176     if not(Input = nil) then
 177     begin
 178       pOldOnOperand := Input.OnOperand;
 179       pOldOnState := Input.OnState;
 180       Input.OnOperand := pOnOperandProc;
 181       Input.OnState := pOnStateProc;
 182     end;
 183   end;
 184
 185   procedure TCustomView.pSetRowCount(Count: Integer);
 186   var
 187     i: Integer;
 188   begin
 189     inherited RowCount := Count;
 190     SetLength(pChanges, inherited ColCount);
 191     for i := 0 to (ColCount - 1) do
 192         SetLength(pChanges[i], inherited RowCount);
 193   end;
 194
 195   constructor TCustomView.CreateView(AOwner: TComponent; Hw: THardware);
 196   begin
 197     inherited Create(AOwner);
 198     ColorTheme := THEME_VIEW_DEFAULT;
 199     RowCount := RowCount;
 200     ScrollBars := ssNone;
 201     {$IFDEF UNIX}
 202     Options := [goRangeSelect, goThumbTracking];
 203     // Behavior of goRangeSelect differ in Lazarus :-(
 204     {$ELSE}
 205     Options := [goThumbTracking];
 206     {$ENDIF}
 207     DefaultDrawing := False;
 208     OnDrawCell := pCustomDrawCell;
 209     OnDblClick := pCustomDblClick;
 210     OnMouseDown := pCustomMouseDown;
 211     OnSelectCell := pOnSelectCell;
 212     Hardware := Hw;
 213   end;
 214
 215   destructor TCustomView.Destroy;
 216   begin
 217     Hardware := nil;
 218     inherited Destroy;
 219   end;
 220
 221 end.