加入收藏 | 设为首页 | 会员中心 | 我要投稿 李大同 （https://www.lidatong.com.cn/）- 科技、建站、经验、云计算、5G、大数据,站长网!
当前位置： 首页 > 大数据 > 正文

delphi – 如何创建可以使用固定的行和列滚动的自定义控件？

发布时间：2020-12-15 04:31:49 所属栏目：大数据 来源：网络整理
导读：我试图弄清楚如何以一种用户可以在所有方向上滚动的方式进行自定义控制,但是使用固定的行和列.网格不适合我正在尝试做的事情,因为它逐列滚动.我需要水平滚动才能像素一样平滑.我没有使用列,只有可视网格线.垂直滚动不仅应滚动右侧区域,还应滚动左侧的固定区
我试图弄清楚如何以一种用户可以在所有方向上滚动的方式进行自定义控制,但是使用固定的行和列.网格不适合我正在尝试做的事情,因为它逐列滚动.我需要水平滚动才能像素一样平滑.我没有使用列,只有可视网格线.垂直滚动不仅应滚动右侧区域,还应滚动左侧的固定区域.与水平滚动相同：标题行应与水平滚动条一起移动.

这只是我正在研究的最终控制的草稿.

请注意滚动条如何不覆盖完整控件,只覆盖较大的区域.固定的列/行也应该能够与其相应的滚动条一起移动.

我应该如何实现滚动条以实现这一目标？

PS – 这是为了取代一个更彻底的问题,因为这是一个误导的请求而被删除的问题.很抱歉,如果我缺少您可能需要了解的细节.

解决方法

首先,我认为你可以使用能够在单元格中保存控件的 this component(样本 image),但是根据你的评论我明白你想要自己画出一切.所以我写了一个’THeaderGrid’组件： 
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;

该组件由三个TPaintScroller控件(TScrollBox上的TPaintBox)构建.实际上,对于这两个标题,TScrollBox有点重量级,但使用与单元格的数据区域相同的控件有点方便.

有三个OnDraw事件,一个用于标题,一个用于单元格,但您可以将它们设置为相同的处理程序,类似于上面的示例.通过列或行索引将每个区分为-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,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,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,akRight];
  FColHeader.OnPaint := PaintColHeader;
  FColHeader.ScrollBars := ssNone;
  FColHeader.Parent := Self;
  FRowHeader := TPaintScroller.Create(Self);
  FRowHeader.Anchors := [akLeft,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,-1,R);
end;

procedure THeaderGrid.DoDrawRowHeader(ACanvas: TCanvas; ARow: Integer;
  R: TRect);
begin
  if Assigned(FOnDrawRowHeader) then
    FOnDrawRowHeader(Self,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,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,Canvas.ClipRect) then
    Canvas.FillRect(R);
  R := Rect(RowHeaderWidth,RowHeaderWidth + 1,Height);
  if IntersectRect(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,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.Top - 1);
      end;
      OffsetRect(R,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,ColHeaderHeight);
  for Col := 0 to FColCount - 1 do
  begin
    if IntersectRect(Dummy,ACanvas.ClipRect) then
      DoDrawColHeader(ACanvas,R);
    OffsetRect(R,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,FRowHeight);
  for Row := 0 to FRowCount - 1 do
  begin
    if IntersectRect(Dummy,ACanvas.ClipRect) then
    begin
      DoDrawRowHeader(ACanvas,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,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,Height);
    FCellScroller.BoundsRect := Rect(RowHeaderWidth + 1,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,ColHeaderHeight);
    FCellScroller.BoundsRect := Rect(Value + 1,ColHeaderHeight + 1,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.

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
    相关内容
      推荐文章
        站长推荐
        热点阅读

          【免责声明】本站内容转载自互联网，其发布内容言论不代表本站观点，如果其链接、内容的侵犯您的权益，烦请提交相关链接至邮箱bqsm@foxmail.com我们将及时予以处理。

          建议您使用1920×1080分辨率、谷歌浏览器Google Chrome、Microsoft Edge以获得本站的最佳浏览效果

          Copygight © 2008-2022 https://www.lidatong.com.cn/ All Rights Reserved. 李大同