logo标签列表

如何创建一个自定义控件，该控件可以滚动，并具有固定的行和列？

delphicustom-controlsscrollbardelphi-xe2
6
我正在尝试找出如何创建一个自定义控件，使用户可以在所有方向上滚动，但行和列保持固定。网格不适合我要做的事情，因为它按列滚动。我需要水平滚动以像素为单位平稳滚动。我不需要列，只需要可视的网格线。垂直滚动应该不仅可以滚动右侧区域，还应该可以滚动左侧的固定区域。水平滚动也是一样：标题行应该随着水平滚动条移动。
这只是我正在开发的最终控件的草稿。
请注意，滚动条不会覆盖整个控件，只会覆盖较大的区域。固定列/行也应能够随其对应的滚动条移动。
我应该如何实现滚动条以使这一切成为可能？
PS- 这是要取代一个被删除的更详细的问题，因为它是一个误导性的请求。如果我缺少您需要知道的细节，请见谅。
2
暂时先看一下这个组件。如果有需要，明天我会有时间为您进行特定的调整。 - NGLN
@NGLN 哇，这个样例控件真是太漂亮了。有很多东西可以学习。实际上，我会非常重视分段绘制，这是我考虑过但一直害怕尝试的一个庞大主题，但是像这样的控件必须从一开始就考虑到这一点。这不是后来才能实现的东西。 - Jerry Dodge
你想用控件或自己的绘画来填充标题和网格吗？网格需要包含什么？你想部分显示行（像列）吗？ - NGLN
@NGLN 我不打算在这个控件内使用任何子控件，尽管如果没有其他选择，我愿意将其用作解决方案。否则，我会逐行（而不是逐单元格）进行100％自定义绘制。 - Jerry Dodge
2个回答
8

首先，我认为您可以使用这个组件（示例图片），它可以在单元格中容纳控件，但是从您的评论中，我理解到您想要自己绘制所有内容。因此，我编写了一个 '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 控件 (一个 TPaintBox 放在 TScrollBox 上) 组成。 实际上，对于两个标题，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, 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.
+1，谢谢，看起来很有希望，除了在XE2中运行时没有显示任何滚动条。有什么想法为什么会这样？ - Jerry Dodge
很奇怪：AutoScroll 属性的默认设置从 True 更改为 False。已修复。 - NGLN
1
再一次，你是我的救命恩人。圣诞快乐，感谢你的礼物（虽然有点超出我在SO上真正需要的规则）。 - Jerry Dodge
1
现在已经过去了4年多，我仍在搜索适合我的控件，并偶然发现了您为我编写的解决方案... - Jerry Dodge
2
最简单的方法是创建一个没有滚动条的控件，然后使用精细的控制来放置滚动条，并调整它们的大小和位置。
在Delphi 3-5中，您可以使用Custom Containers Pack将其封装为新控件，并像常规网格一样将其放置在新表单上。
由于D5 CCP已不再提供，但VCL TFrame提供了有限的类似功能。
或者，您可以在运行时创建这些滚动条 - 您需要搜索Windows Handle创建例程（跟踪TControl.Handle getter方法），可能是ReCreateWnd或类似方法，然后在其上创建滚动条。
3
我已将更新后的CCP版本放在SourceForge上，其中包含了适用于Delphi XE2及以下版本的软件包。https://sourceforge.net/projects/ccpack/ 升级到XE3应该不会太困难。(我尚未测试Delphi 2007以上版本中的情况，可能存在漏洞。) - dummzeuch
这是一个很棒的工具，但对于我需要的有点多了。不过，我肯定会将其用于我的其他小玩意儿上！ - Jerry Dodge
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接