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

前端 未结 2 468
生来不讨喜
生来不讨喜 2021-01-05 12:20

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

相关标签:
2条回答
  • 2021-01-05 13:01

    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.

    0 讨论(0)
  • 2021-01-05 13:20

    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;
    

    Screenshot

    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.
    
    0 讨论(0)
提交回复
热议问题