xcomps.~pas

平板表格控件(带源码).

{
  已知的BUG:
    NoAppend对TAB键无效
    无论何时进入编辑状态总会引起正屏刷新？
}
unit xcomps;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, StdCtrls, DBCtrls, DBGrids, DB, Math, Mask, DBTables,
  Variants;

type
  TxDBNavigator = class(TDBNavigator)
  private
    function ReadBtnEnabled(nb: TNavigateBtn): Boolean;
    procedure SetBtnEnabled(nb: TNavigateBtn; Enabled: Boolean);
  public
    constructor Create(AOwner: TComponent);override;
    property BtnEnabled[nb: TNavigateBtn]: Boolean read
      ReadBtnEnabled write SetBtnEnabled;
  published
    property Font;
  end;

{ -- 以下为xDBGrid -- }
const
  MaxField = 50;

type

  THeadTreeNode = class;
  TxDBGrid = class;

  LeafCol = record
    FLeaf:THeadTreeNode;
    FColumn:TColumn;
  end;

  PLeafCol = ^LeafCol;
//  ArrLeafCol = array[0..MaxListSize - 1] of LeafCol;
  TLeafCol = array[0..MaxListSize - 1] of LeafCol;
  PTLeafCol = ^TLeafCol;

{  THeadTreeNode }

  THeadTreeProc = procedure (node:THeadTreeNode) of object;
  THeadTreeNode = class(TObject) // new
  public
    Host:THeadTreeNode;
    Child:THeadTreeNode;
    Next:THeadTreeNode;
    Text:String;
    Height:Integer;
    Width:Integer;
    Drawed:Boolean;
    constructor Create;
    constructor CreateText(AText:String;AHeight,AWidth:Integer);
    destructor Destroy; override;
    function Add(AAfter: THeadTreeNode; AText:String;
      AHeight,AWidth:Integer):THeadTreeNode ;
    function AddChild(ANode:THeadTreeNode;AText:String;
      AHeight,AWidth:Integer):THeadTreeNode ;
    function Find(ANode:THeadTreeNode):Boolean;
    procedure Union(AFrom,ATo :THeadTreeNode;
      AText:String;AHeight:Integer);
    procedure FreeAllChild;
    procedure CreateFieldTree(AGrid:TxDBGrid);
    procedure DoForAllNode(proc:THeadTreeProc);
  end;

  TxDBGrid = class(TDBGrid)
  private
    FSelRow: Integer;      // -- new ?????????????
    FTitleOffset: Integer; // -- new;
//    FIndicatorOffset: Integer;
    FNoAppend: Boolean;
    FIndicators: TImageList; // -- new;
    FLineColor: TColor;
    FSumColor: TColor;
    FTopSumRows: Integer;
    FBottomSumRows: Integer;
    FSumFlag: string;
    FOldValues:  array[0..MaxField] of Variant;
    FSumArray:   array[0..MaxField] of Variant;
    FEventArray: array[0..MaxField] of TFieldNotifyEvent;
    FMasterQuery: TQuery;
    FEventMasterScroll: TDataSetNotifyEvent;
    FEventBeforeDelete: TDataSetNotifyEvent;
    FEventBeforeCancel: TDataSetNotifyEvent;
    FEventAfterCancel:  TDataSetNotifyEvent;

    // 原函数只刷新标题，增加整屏刷新
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    // 设置格线、统计行颜色。新增
    procedure SetLineColor(clr: TColor);
    procedure SetSumColor(clr: TColor);
    // 计算在整个ClientHeight中,实际能以DefaultRowHeight
    // 画多少个可卷动行,及最后一行的第线坐标
    function MaxRowCount: Integer;
    function MaxRowHeight: integer;
    // 计算给定字段在COLUMNS中位置
    function IndexOfColumn(fld: TField): Integer;
    function IndexOfSumFlag(ACol: Integer): string;
    procedure SetSumFlag(ACol: Integer; flag: string);
    procedure WriteSumFlag(flag: string);
    function GetSums(idx: Integer): real;
    // 只是因为需要
    function IsActiveControl: Boolean;
    // 为减少修改程序量，直接取变量名为函数名
    function FIndicatorOffset: Integer;
  protected
    FTitleHeight: Integer; {--------------new--------------}
    FTitleLines: Integer;  {--------------new--------------}
    FTitleHeightFull: Integer; {new}

    FMarginText:Boolean;
    FVTitleMargin: Integer;
    FHTitleMargin: Integer;
    FUseMultiTitle: Boolean;

    // 直接覆盖最TCustomGrid方法，无论任何行数量的
    // 改动均强制改成满屏行
    procedure SizeChanged(OldColCount, OldRowCount: Longint); override;
    // 覆盖原方法
    procedure Paint;override;
    procedure DrawCell(ACol, ARow: Longint;
      ARect: TRect; AState: TGridDrawState); override;
    procedure LayoutChanged; override;
    procedure Scroll(Distance: Integer); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;

    // 重新定义原始被隐藏的方法，不做修改
    procedure UpdateRowCount;
    procedure UpdateActive;
    procedure UpdateScrollBar;
    // 加载自己的编辑器，使之高度固定在DefaultRowHeigh上
    function  CreateEditor: TInplaceEdit; override;
    // 专门针对统计的一系列方法
    procedure OnFieldChange(Sender: TField);
    procedure LinkActive(Value: Boolean); override;
    function GetEditText(ACol, ARow: Longint): string;override;
//    procedure SetEditText(ACol, ARow: Longint; const Value: string); override;
    procedure OnMasterScroll(DataSet: TDataSet);
    procedure OnBeforeDelete(DataSet: TDataSet);
    procedure OnBeforeCancel(DataSet: TDataSet);
    procedure OnAfterCancel(DataSet: TDataSet);
    procedure CalcSum;
    function FormatSum(Value: Variant; AField: TField): string;
    procedure DrawSumCell(ACol: Integer);virtual;

    // 多行标题
    procedure ClearPainted(node:THeadTreeNode);
    function SetChildTreeHeight(ANode:THeadTreeNode):Integer;
    function  ReadTitleHeight: Integer;
    procedure WriteTitleHeight(th: Integer);
    function  ReadTitleLines: Integer;
    procedure WriteTitleLines(tl: Integer);
    procedure WriteMarginText(IsMargin:Boolean);
    procedure WriteVTitleMargin(Value: Integer);
    procedure WriteHTitleMargin(Value: Integer);
    procedure WriteUseMultiTitle(Value:Boolean);
  public
    FHeadTree:THeadTreeNode;
    FLeafFieldArr:PTLeafCol;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Sums[idx: Integer]: real read GetSums;

  published
    property TitleHeight : Integer read ReadTitleHeight
      write WriteTitleHeight default 24;
    property TitleLines : Integer read ReadTitleLines
      write WriteTitleLines default 0;
    property VTitleMargin: Integer read FVTitleMargin
      write WriteVTitleMargin default 10;
    property HTitleMargin: Integer read FHTitleMargin
      write WriteHTitleMargin default 0;
    property UseMultiTitle: Boolean read FUseMultiTitle
      write WriteUseMultiTitle default False;
    // 标准格线颜色
    property LineColor: TColor read FLineColor write SetLineColor;
    property SumColor: TColor read FSumColor write SetSumColor;
    property SumFlag: String read FSumFlag write WriteSumFlag;
    property NoAppend: boolean read FNoAppend write FNoAppend;
  end;


  TCharSet = Set of Char;

procedure Register;

implementation

(* $R xDBGRIDS.RES 放弃indicator位图 *)

procedure Register;
begin
  RegisterComponents('Samples', [TxDBNavigator, TxDBGrid]);
end;

constructor TxDBNavigator.Create(AOwner :TComponent);
begin
  inherited Create(aOwner);
  Buttons[nbFirst  ].Caption:='首条';
  Buttons[nbPrior  ].Caption:='前条';
  Buttons[nbNext   ].Caption:='后条';
  Buttons[nbLast   ].Caption:='末条';
  Buttons[nbInsert ].Caption:='插入';
  Buttons[nbDelete ].Caption:='删除';
  Buttons[nbEdit   ].Caption:='编辑';
  Buttons[nbPost   ].Caption:='存盘';
  Buttons[nbCancel ].Caption:='放弃';
  Buttons[nbRefresh].Caption:='刷新';
end;

function TxDBNavigator.ReadBtnEnabled(nb: TNavigateBtn): Boolean;
begin
  Result := Buttons[nb].Enabled;
end;

procedure TxDBNavigator.SetBtnEnabled(nb: TNavigateBtn; Enabled: Boolean);
begin
  DataChanged;
  EditingChanged;
  Buttons[nb].Enabled := (Buttons[nb].Enabled and Enabled);
end;

type
  PIntArray = ^TIntArray;
  TIntArray = array[0..MaxCustomExtents] of Integer;

// 为避免资源冲突，自行定义相应的行指示标位图
// 修改为放弃位图
{const
  bmArrow = 'xDBGARROW';
  bmEdit = 'xDBEDIT';
  bmInsert = 'xDBINSERT';
  bmMultiDot = 'xDBMULTIDOT';
  bmMultiArrow = 'xDBMULTIARROW';}

var
  DrawBitmap: TBitmap;
  UserCount: Integer;

procedure UsesBitmap;
begin
  if UserCount = 0 then
    DrawBitmap := TBitmap.Create;
  Inc(UserCount);
end;

procedure ReleaseBitmap;
begin
  Dec(UserCount);
  if UserCount = 0 then DrawBitmap.Free;
end;

procedure WriteText(ACanvas: TCanvas; ARect: TRect; DX, DY: Integer;
  const Text: string; Alignment: TAlignment; ARightToLeft: Boolean);
const
  AlignFlags : array [TAlignment] of Integer =
    ( DT_LEFT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_RIGHT or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX,
      DT_CENTER or DT_WORDBREAK or DT_EXPANDTABS or DT_NOPREFIX );
  RTL: array [Boolean] of Integer = (0, DT_RTLREADING);
var
  B, R: TRect;
  Hold, Left: Integer;
  I: TColorRef;
begin
  I := ColorToRGB(ACanvas.Brush.Color);
  if GetNearestColor(ACanvas.Handle, I) = I then
  begin                       { Use ExtTextOut for solid colors }
    { In BiDi, because we changed the window origin, the text that does not
      change alignment, actually gets its alignment changed. }
    if (ACanvas.CanvasOrientation = coRightToLeft) and (not ARightToLeft) then
      ChangeBiDiModeAlignment(Alignment);
    case Alignment of
      taLeftJustify:
        Left := ARect.Left + DX;
      taRightJustify:
        Left := ARect.Right - ACanvas.TextWidth(Text) - 3;
    else { taCenter }
      Left := ARect.Left + (ARect.Right - ARect.Left) shr 1
        - (ACanvas.TextWidth(Text) shr 1);
    end;
    ACanvas.TextRect(ARect, Left, ARect.Top + DY, Text);
  end
  else begin                  { Use FillRect and Drawtext for dithered colors }
    DrawBitmap.Canvas.Lock;
    try
      with DrawBitmap, ARect do { Use offscreen bitmap to eliminate flicker and }
      begin                     { brush origin tics in painting / scrolling.    }
        Width := Max(Width, Right - Left);
        Height := Max(Height, Bottom - Top);
        R := Rect(DX, DY, Right - Left - 1, Bottom - Top - 1);
        B := Rect(0, 0, Right - Left, Bottom - Top);
      end;
      with DrawBitmap.Canvas do
      begin
        Font := ACanvas.Font;
        Font.Color := ACanvas.Font.Color;
        Brush := ACanvas.Brush;
        Brush.Style := bsSolid;
        FillRect(B);
        SetBkMode(Handle, TRANSPARENT);
        if (ACanvas.CanvasOrientation = coRightToLeft) then
          ChangeBiDiModeAlignment(Alignment);
        DrawText(Handle, PChar(Text), Length(Text), R,
          AlignFlags[Alignment] or RTL[ARightToLeft]);
      end;
      if (ACanvas.CanvasOrientation = coRightToLeft) then
      begin
        Hold := ARect.Left;
        ARect.Left := ARect.Right;
        ARect.Right := Hold;
      end;
      ACanvas.CopyRect(ARect, DrawBitmap.Canvas, B);
    finally
      DrawBitmap.Canvas.Unlock;
    end;
  end;
end;

////////
///{strUtils}
////////

function WordPosition(const N: Integer; const S: string; WordDelims: TCharSet): Integer;
var
  Count, I: Integer;
begin
  Count := 0;
  I := 1;
  Result := 0;
  while (I <= Length(S)) and (Count <> N) do begin
    { skip over delimiters }
    while (I <= Length(S)) and (S[I] in WordDelims) do Inc(I);
    { if we're not beyond end of S, we're at the start of a word }
    if I <= Length(S) then Inc(Count);
    { if not finished, find the end of the current word }
    if Count <> N then
      while (I <= Length(S)) and not (S[I] in WordDelims) do Inc(I)
    else Result := I;
  end;
end;

function ExtractWord(N: Integer; const S: string; WordDelims: TCharSet): string;
var
  I: Word;
  Len: Integer;
begin
  Len := 0;
  I := WordPosition(N, S, WordDelims);
  if I <> 0 then
    { find the end of the current word }
    while (I <= Length(S)) and not(S[I] in WordDelims) do begin
      { add the I'th character to result }
      Inc(Len);
      SetLength(Result, Len);
      Result[Len] := S[I];
      Inc(I);
    end;
  SetLength(Result, Len);