1. 技术文章
  2. How to create a custom control which can scroll with a fixed row and column?

How to create a custom control which can scroll with a fixed row and column?

由 醉酒当歌 提交于 2020-01-01 09:57:15

问题


I'm trying to figure out how I can make a custom control in a way where user can scroll in all directions, but with a fixed row and column. A grid is not suitable for what I'm trying to do, because it scrolls column by column. I need horizontal scrolling to be smooth, pixel by pixel. I have no use for columns, only visual grid lines. Vertical scrolling should scroll not only the area on the right, but also the fixed region on the left. Same with horizontal scrolling: the header row should move along with the horizontal scrollbar.

This is just a rough draft of the final control I'm working on.

Note how the scrollbars do not cover the full control, only the larger region. The fixed column/row should also be able to move along with their corresponding scrollbar.

How should I implement the scrollbars to make this possible?

PS - This is to replace a much more thorough question which was deleted for being a mis-leading request. So sorry if I'm lacking details which you might need to know.


回答1:


First, I thought you could do with this component (sample image) which is capable of holding controls in cells, but from your comment I understand that you want to draw everything yourself. So I wrote a 'THeaderGrid' component:

procedure TForm1.FormCreate(Sender: TObject);
begin
  with THeaderGrid.Create(Self) do
  begin
    Align := alClient;
    OnDrawCell := DrawCell;
    OnDrawColHeader := DrawCell;
    OnDrawRowHeader := DrawCell;
    Parent := Self;
  end;
end;

procedure TForm1.DrawCell(Sender: TObject; ACanvas: TCanvas; ACol,
  ARow: Integer; R: TRect);
begin
  ACanvas.TextOut(R.Left + 2, R.Top + 2, Format('(%d,%d)', [ACol, ARow]));
end;

The component is build up out of three TPaintScroller controls (a TPaintBox on a TScrollBox). Actually, for both headers, TScrollBox is a little bit heavyweighted, but it was kind of handy to use the same control as for the data region with the cells.

There are three OnDraw events, one for both headers and one for the cells, but you could all set them to the same handler, alike the example above. Distinguish each by the column or row index being -1.

unit HeaderGrid;

interface

uses
  Classes, Controls, Windows, Messages, Graphics, Forms, ExtCtrls, StdCtrls;

type
  TPaintEvent = procedure(ACanvas: TCanvas) of object;

  TPaintScroller = class(TScrollingWinControl)
  private
    FOnPaint: TPaintEvent;
    FOnScroll: TNotifyEvent;
    FPainter: TPaintBox;
    function GetPaintHeight: Integer;
    function GetPaintWidth: Integer;
    function GetScrollBars: TScrollStyle;
    procedure SetPaintHeight(Value: Integer);
    procedure SetPaintWidth(Value: Integer);
    procedure SetScrollBars(Value: TScrollStyle);
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMHScroll(var Message: TWMScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMScroll); message WM_VSCROLL;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure DoPaint(Sender: TObject); virtual;
    procedure DoScroll; virtual;
    procedure PaintWindow(DC: HDC); override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property OnPaint: TPaintEvent read FOnPaint write FOnPaint;
    property OnScroll: TNotifyEvent read FOnScroll write FOnScroll;
    property PaintHeight: Integer read GetPaintHeight write SetPaintHeight;
    property PaintWidth: Integer read GetPaintWidth write SetPaintWidth;
    property ScrollBars: TScrollStyle read GetScrollBars write SetScrollBars
      default ssBoth;
  end;

  TDrawCellEvent = procedure(Sender: TObject; ACanvas: TCanvas; ACol,
    ARow: Integer; R: TRect) of object;

  THeaderGrid = class(TCustomControl)
  private
    FCellScroller: TPaintScroller;
    FColCount: Integer;
    FColHeader: TPaintScroller;
    FColWidth: Integer;
    FOnDrawCell: TDrawCellEvent;
    FOnDrawColHeader: TDrawCellEvent;
    FOnDrawRowHeader: TDrawCellEvent;
    FRowCount: Integer;
    FRowHeader: TPaintScroller;
    FRowHeight: Integer;
    procedure CellsScrolled(Sender: TObject);
    function GetColHeaderHeight: Integer;
    function GetRowHeaderWidth: Integer;
    procedure PaintCells(ACanvas: TCanvas);
    procedure PaintColHeader(ACanvas: TCanvas);
    procedure PaintRowHeader(ACanvas: TCanvas);
    procedure SetColCount(Value: Integer);
    procedure SetColHeaderHeight(Value: Integer);
    procedure SetColWidth(Value: Integer);
    procedure SetRowCount(Value: Integer);
    procedure SetRowHeaderWidth(Value: Integer);
    procedure SetRowHeight(Value: Integer);
    procedure UpdateSize;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DoDrawCell(ACanvas: TCanvas; ACol, ARow: Integer;
      R: TRect); virtual;
    procedure DoDrawColHeader(ACanvas: TCanvas; ACol: Integer;
      R: TRect); virtual;
    procedure DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
      R: TRect); virtual;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure MouseWheelHandler(var Message: TMessage); override;
  published
    property ColCount: Integer read FColCount write SetColCount default 5;
    property ColHeaderHeight: Integer read GetColHeaderHeight
      write SetColHeaderHeight default 24;
    property ColWidth: Integer read FColWidth write SetColWidth default 64;
    property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
    property OnDrawColHeader: TDrawCellEvent read FOnDrawColHeader
      write FOnDrawColHeader;
    property OnDrawRowHeader: TDrawCellEvent read FOnDrawRowHeader
      write FOnDrawRowHeader;
    property RowCount: Integer read FRowCount write SetRowCount default 5;
    property RowHeaderWidth: Integer read GetRowHeaderWidth
      write SetRowHeaderWidth default 64;
    property RowHeight: Integer read FRowHeight write SetRowHeight default 24;
  published
    property Color;
    property Font;
    property ParentColor default False;
    property TabStop default True;
  end;

implementation

{ TPaintScroller }

constructor TPaintScroller.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
  HorzScrollBar.Tracking := True;
  VertScrollBar.Tracking := True;
  Width := 100;
  Height := 100;
  FPainter := TPaintBox.Create(Self);
  FPainter.SetBounds(0, 0, 100, 100);
  FPainter.OnPaint := DoPaint;
  FPainter.Parent := Self;
end;

procedure TPaintScroller.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params.WindowClass do
    Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;

function TPaintScroller.DoMouseWheel(Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
  VertScrollBar.Position := VertScrollBar.Position - WheelDelta;
  DoScroll;
  Result := True;
end;

procedure TPaintScroller.DoPaint(Sender: TObject);
begin
  if Assigned(FOnPaint) then
    FOnPaint(FPainter.Canvas);
end;

procedure TPaintScroller.DoScroll;
begin
  if Assigned(FOnScroll) then
    FOnScroll(Self);
end;

function TPaintScroller.GetPaintHeight: Integer;
begin
  Result := FPainter.Height;
end;

function TPaintScroller.GetPaintWidth: Integer;
begin
  Result := FPainter.Width;
end;

function TPaintScroller.GetScrollBars: TScrollStyle;
begin
  if HorzScrollBar.Visible and VertScrollBar.Visible then
    Result := ssBoth
  else if not HorzScrollBar.Visible and VertScrollBar.Visible then
    Result := ssVertical
  else if HorzScrollBar.Visible and not VertScrollBar.Visible then
    Result := ssHorizontal
  else
    Result := ssNone;
end;

procedure TPaintScroller.PaintWindow(DC: HDC);
begin
  with FPainter do
    ExcludeClipRect(DC, 0, 0, Width + Left, Height + Top);
  FillRect(DC, ClientRect, Brush.Handle);
end;

procedure TPaintScroller.Resize;
begin
  DoScroll;
  inherited Resize;
end;

procedure TPaintScroller.SetPaintHeight(Value: Integer);
begin
  FPainter.Height := Value;
end;

procedure TPaintScroller.SetPaintWidth(Value: Integer);
begin
  FPainter.Width := Value;
end;

procedure TPaintScroller.SetScrollBars(Value: TScrollStyle);
begin
  HorzScrollBar.Visible := (Value = ssBoth) or (Value = ssHorizontal);
  VertScrollBar.Visible := (Value = ssBoth) or (Value = ssVertical);
end;

procedure TPaintScroller.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TPaintScroller.WMHScroll(var Message: TWMScroll);
begin
  inherited;
  DoScroll;
end;

procedure TPaintScroller.WMVScroll(var Message: TWMScroll);
begin
  inherited;
  DoScroll;
end;

{ THeaderGrid }

procedure THeaderGrid.CellsScrolled(Sender: TObject);
begin
  FColHeader.FPainter.Left := -FCellScroller.HorzScrollBar.Position;
  FRowHeader.FPainter.Top := -FCellScroller.VertScrollBar.Position;
end;

constructor THeaderGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque];
  ParentColor := False;
  TabStop := True;
  FCellScroller := TPaintScroller.Create(Self);
  FCellScroller.Anchors := [akLeft, akTop, akRight, akBottom];
  FCellScroller.OnPaint := PaintCells;
  FCellScroller.OnScroll := CellsScrolled;
  FCellScroller.AutoScroll := True;
  FCellScroller.Parent := Self;
  FColHeader := TPaintScroller.Create(Self);
  FColHeader.Anchors := [akLeft, akTop, akRight];
  FColHeader.OnPaint := PaintColHeader;
  FColHeader.ScrollBars := ssNone;
  FColHeader.Parent := Self;
  FRowHeader := TPaintScroller.Create(Self);
  FRowHeader.Anchors := [akLeft, akTop, akBottom];
  FRowHeader.OnPaint := PaintRowHeader;
  FRowHeader.ScrollBars := ssNone;
  FRowHeader.Parent := Self;
  Width := 320;
  Height := 120;
  ColCount := 5;
  RowCount := 5;
  ColWidth := 64;
  RowHeight := 24;
  ColHeaderHeight := 24;
  RowHeaderWidth := 64;
end;

procedure THeaderGrid.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params.WindowClass do
    Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure THeaderGrid.DoDrawCell(ACanvas: TCanvas; ACol, ARow: Integer;
  R: TRect);
begin
  if Assigned(FOnDrawCell) then
    FOnDrawCell(Self, ACanvas, ACol, ARow, R);
end;

procedure THeaderGrid.DoDrawColHeader(ACanvas: TCanvas; ACol: Integer;
  R: TRect);
begin
 if Assigned(FOnDrawColHeader) then
   FOnDrawColHeader(Self, ACanvas, ACol, -1, R);
end;

procedure THeaderGrid.DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
  R: TRect);
begin
  if Assigned(FOnDrawRowHeader) then
    FOnDrawRowHeader(Self, ACanvas, -1, ARow, R);
end;

function THeaderGrid.GetColHeaderHeight: Integer;
begin
  Result := FColHeader.Height;
end;

function THeaderGrid.GetRowHeaderWidth: Integer;
begin
  Result := FRowHeader.Width;
end;

procedure THeaderGrid.MouseWheelHandler(var Message: TMessage);
begin
  with Message do
    Result := FCellScroller.Perform(CM_MOUSEWHEEL, WParam, LParam);
  if Message.Result = 0 then
    inherited MouseWheelHandler(Message);
end;

procedure THeaderGrid.Paint;
var
  R: TRect;
begin
  Canvas.Brush.Color := Color;
  R := Rect(0, 0, RowHeaderWidth, ColHeaderHeight);
  if IntersectRect(R, R, Canvas.ClipRect) then
    Canvas.FillRect(R);
  Canvas.Brush.Color := clBlack;
  R := Rect(0, ColHeaderHeight, Width, ColHeaderHeight + 1);
  if IntersectRect(R, R, Canvas.ClipRect) then
    Canvas.FillRect(R);
  R := Rect(RowHeaderWidth, 0, RowHeaderWidth + 1, Height);
  if IntersectRect(R, R, Canvas.ClipRect) then
    Canvas.FillRect(R);
end;

procedure THeaderGrid.PaintCells(ACanvas: TCanvas);
var
  Col: Integer;
  Row: Integer;
  R: TRect;
  Dummy: TRect;
begin
  ACanvas.Brush.Color := Color;
  ACanvas.Font := Font;
  ACanvas.FillRect(ACanvas.ClipRect);
  for Row := 0 to FRowCount - 1 do
  begin
    R := Bounds(0, Row * FRowHeight, FColWidth, FRowHeight);
    for Col := 0 to FColCount - 1 do
    begin
      if IntersectRect(Dummy, R, ACanvas.ClipRect) then
      begin
        DoDrawCell(ACanvas, Col, Row, R);
        if ACanvas.Pen.Style <> psSolid then
          ACanvas.Pen.Style := psSolid;
        if ACanvas.Pen.Color <> clSilver then
          ACanvas.Pen.Color := clSilver;
        ACanvas.MoveTo(R.Left, R.Bottom - 1);
        ACanvas.LineTo(R.Right - 1, R.Bottom - 1);
        ACanvas.LineTo(R.Right - 1, R.Top - 1);
      end;
      OffsetRect(R, FColWidth, 0);
    end;
  end;
end;

procedure THeaderGrid.PaintColHeader(ACanvas: TCanvas);
var
  Col: Integer;
  R: TRect;
  Dummy: TRect;
begin
  ACanvas.Brush.Color := Color;
  ACanvas.Font := Font;
  ACanvas.FillRect(ACanvas.ClipRect);
  R := Rect(0, 0, FColWidth, ColHeaderHeight);
  for Col := 0 to FColCount - 1 do
  begin
    if IntersectRect(Dummy, R, ACanvas.ClipRect) then
      DoDrawColHeader(ACanvas, Col, R);
    OffsetRect(R, FColWidth, 0);
  end;
end;

procedure THeaderGrid.PaintRowHeader(ACanvas: TCanvas);
var
  Row: Integer;
  R: TRect;
  Dummy: TRect;
begin
  ACanvas.Brush.Color := Color;
  ACanvas.Font := Font;
  ACanvas.FillRect(ACanvas.ClipRect);
  R := Rect(0, 0, RowHeaderWidth, FRowHeight);
  for Row := 0 to FRowCount - 1 do
  begin
    if IntersectRect(Dummy, R, ACanvas.ClipRect) then
    begin
      DoDrawRowHeader(ACanvas, Row, R);
      if ACanvas.Pen.Style <> psSolid then
        ACanvas.Pen.Style := psSolid;
      if ACanvas.Pen.Color <> clSilver then
        ACanvas.Pen.Color := clSilver;
      ACanvas.MoveTo(R.Left, R.Bottom - 1);
      ACanvas.LineTo(R.Right - 1, R.Bottom - 1);
    end;
    OffsetRect(R, 0, FRowHeight);
  end;
end;

procedure THeaderGrid.SetColCount(Value: Integer);
begin
  if FColCount <> Value then
  begin
    FColCount := Value;
    UpdateSize;
  end;
end;

procedure THeaderGrid.SetColHeaderHeight(Value: Integer);
begin
  if Value >= 0 then
  begin
    FColHeader.Height := Value;
    FRowHeader.BoundsRect := Rect(0, Value + 1, RowHeaderWidth, Height);
    FCellScroller.BoundsRect := Rect(RowHeaderWidth + 1, Value + 1, Width,
      Height);
  end;
end;

procedure THeaderGrid.SetColWidth(Value: Integer);
begin
  if FColWidth <> Value then
  begin
    FColWidth := Value;
    FCellScroller.HorzScrollBar.Increment := Value;
    UpdateSize;
  end;
end;

procedure THeaderGrid.SetRowCount(Value: Integer);
begin
  if FRowCount <> Value then
  begin
    FRowCount := Value;
    UpdateSize;
  end;
end;

procedure THeaderGrid.SetRowHeaderWidth(Value: Integer);
begin
  if Value >= 0 then
  begin
    FRowHeader.Width := Value;
    FColHeader.BoundsRect := Rect(Value + 1, 0, Width, ColHeaderHeight);
    FCellScroller.BoundsRect := Rect(Value + 1, ColHeaderHeight + 1, Width,
      Height);
  end;
end;

procedure THeaderGrid.SetRowHeight(Value: Integer);
begin
  if FRowHeight <> Value then
  begin
    FRowHeight := Value;
    FCellScroller.VertScrollBar.Increment := Value;
    UpdateSize;
  end;
end;

procedure THeaderGrid.UpdateSize;
begin
  FColHeader.PaintWidth := FColCount * FColWidth;
  FRowHeader.PaintHeight := FRowCount * FRowHeight;
  FCellScroller.PaintWidth := FColCount * FColWidth;
  FCellScroller.PaintHeight := FRowCount * FRowHeight;
end;

procedure THeaderGrid.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

end.



回答2:


The easiest way is to make a control without scrollbars and then put scrollbars over it with fine control of their size and position.

With Delphi 3-5 you could then encapsulate it as your new control using Custom Containers Pack, and drop onto new forms just like u do with regular grid.

Since D5 CCP is no more available but limited analogue is given as VCL TFrame. OR you can create those scrollbars in runtime - you need to search for Windows Handle creating routine, (trace TControl.Handle getter method), that might be ReCreateWnd or such, and as GDI handle created - create your scroll-bars over it.



来源：https://stackoverflow.com/questions/13983858/how-to-create-a-custom-control-which-can-scroll-with-a-fixed-row-and-column

标签
Delphi
custom-controls
scrollbar
delphi-xe2
易学教程内所有资源均来自网络或用户发布的内容，如有违反法律规定的内容欢迎反馈！
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!