easygrid_0811.pas

delphi制作表格的控件

    property DragMode;
    property Enabled;
    property FixedLineColor;
    property ClientLineColor;
    property FixedCols;
    property RowCount;
    property FixedRows;
    property Font;
    property GridLineWidth;
    property Options;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property GridCanCopyMove;
    property GridCanFill;
    property ScrollBars;
    property ShowHint;
    property ShowPopup;
    property TabOrder;
    property TabStop;
    property Visible;
    property VisibleColCount;
    property VisibleRowCount;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnGetEditMask: TGetEditEvent read FOnGetEditMask write FOnGetEditMask;
    property OnGetEditText: TGetEditEvent read FOnGetEditText write FOnGetEditText;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    property OnSelectCell: TSelectCellEvent read FOnSelectCell write FOnSelectCell;
    property OnSetEditText: TSetEditEvent read FOnSetEditText write FOnSetEditText;
    property OnHideEdit: TSetEditEvent read FOnHideEdit write FOnHideEdit;
    property OnSetForeText: TSetCellTextEvent read FOnSetForeText write FOnSetForeText;
    property OnSetBackText: TSetCellTextEvent read FOnSetBackText write FOnSetBackText;
    property BeforeSetCellProp: TBeforeSetCellPropEvent read FBeforeSetCellProp write FBeforeSetCellProp;
    property AfterSetCellProp: TAfterSetCellPropEvent read FAfterSetCellProp write FAfterSetCellProp;
    property OnStartDock;
    property OnStartDrag;
    property OnTopLeftChanged: TNotifyEvent read FOnTopLeftChanged write FOnTopLeftChanged;
    property OnInsertCol: TInsertColEvent read FOnInsertCol write FOnInsertCol;
    property OnInsertRow: TInsertRowEvent read FOnInsertRow write FOnInsertRow;
    property OnDeleteCol: TDeleteColEvent read FOnDeleteCol write FOnDeleteCol;
    property OnDeleteRow: TDeleteRowEvent read FOnDeleteRow write FOnDeleteRow;
    property OnInsertCellRight: TInsertCellRightEvent read FOnInsertCellRight write FOnInsertCellRight;
    property OnInsertCellDown: TInsertCellDownEvent read FOnInsertCellDown write FOnInsertCellDown;
    property OnDeleteCellRight: TDeleteCellRightEvent read FOnDeleteCellRight write FOnDeleteCellRight;
    property OnDeleteCellDown: TDeleteCellDownEvent read FOnDeleteCellDown write FOnDeleteCellDown;
    property OnPasteCells: TPasteCellsEvent read FOnPasteCells write FOnPasteCells;
    property OnCutCells: TCutCellsEvent read FOnCutCells write FOnCutCells;
    property OnCopyMoveCells: TCopyMoveCellsEvent read FOnCopyMoveCells write FOnCopyMoveCells;
    property OnFillCells: TFillCellsEvent read FOnFillCells write FOnFillCells;
//---------Add By Liuzhigang In 2004.07.30--------------------
    property DataSource;
    //User Define
    property HighLightColor;
    property TitleColor;
    property ShowColTitle;
    property ShowRowTitle;
    property FocusedTitleColor;
    property HighLightTextColor;
  end;


implementation
uses Math, Consts;


procedure KillMessage(Wnd: HWnd; Msg: Integer);
// Delete the requested message from the queue, but throw back
// any WM_QUIT msgs that PeekMessage may also return
var
  M: TMsg;
begin
  M.Message := 0;
  if PeekMessage(M, Wnd, Msg, Msg, pm_Remove) and (M.Message = WM_QUIT) then
    PostQuitMessage(M.wparam);
end;

function ColTitle(Index: Integer) : string;
var
  Hi,Lo : Integer;
begin
  Result := '';
  if (Index < 0) or (Index > 255) then Exit;
  Hi := Index div 26;
  Lo := Index mod 26;
  if Index<=25 then
     Result := Chr(Ord('A')+Lo)
  else
     Result := Chr(Ord('A')+Hi-1) + Chr(Ord('A')+Lo);
end;

procedure InvalidOp(const id: string);
begin
  raise EInvalidGridOperation.Create(id);
end;

function GridCoord(X, Y: Integer): TGridCoord;
begin
  Result.X := X;
  Result.Y := Y;
end;

function GridRect(Coord1, Coord2: TGridCoord): TGridRect;
begin
  with Result do
  begin
    Left := Coord2.X;
    if Coord1.X < Coord2.X then Left := Coord1.X;
    Right := Coord1.X;
    if Coord1.X < Coord2.X then Right := Coord2.X;
    Top := Coord2.Y;
    if Coord1.Y < Coord2.Y then Top := Coord1.Y;
    Bottom := Coord1.Y;
    if Coord1.Y < Coord2.Y then Bottom := Coord2.Y;
  end;
end;

function PointInGridRect(Col, Row: Longint; const Rect: TGridRect): Boolean;
begin
  Result := (Col >= Rect.Left) and (Col <= Rect.Right) and (Row >= Rect.Top)
    and (Row <= Rect.Bottom);
end;

function GridRectInterSects(GridRect1, GridRect2: TGridRect): Boolean;
var
  i, j: Integer;
begin
  Result := True;
  for i:=GridRect1.Left to GridRect1.Right do
    for j:=GridRect1.Top to GridRect1.Bottom do
      if PointInGridRect(i, j, GridRect2) then
         Exit;
  Result := False;
end;

type
  TXorRects = array[0..3] of TRect;

procedure XorRects(const R1, R2: TRect; var XorRects: TXorRects);
var
  Intersect, Union: TRect;

  function PtInRect(X, Y: Integer; const Rect: TRect): Boolean;
  begin
    with Rect do Result := (X >= Left) and (X <= Right) and (Y >= Top) and
      (Y <= Bottom);
  end;

  function Includes(const P1: TPoint; var P2: TPoint): Boolean;
  begin
    with P1 do
    begin
      Result := PtInRect(X, Y, R1) or PtInRect(X, Y, R2);
      if Result then P2 := P1;
    end;
  end;

  function Build(var R: TRect; const P1, P2, P3: TPoint): Boolean;
  begin
    Build := True;
    with R do
      if Includes(P1, TopLeft) then
      begin
        if not Includes(P3, BottomRight) then BottomRight := P2;
      end
      else if Includes(P2, TopLeft) then BottomRight := P3
      else Build := False;
  end;

begin
  FillChar(XorRects, SizeOf(XorRects), 0);
  if not Bool(IntersectRect(Intersect, R1, R2)) then
  begin
    { Don't intersect so its simple }
    XorRects[0] := R1;
    XorRects[1] := R2;
  end
  else
  begin
    UnionRect(Union, R1, R2);
    if Build(XorRects[0],
      Point(Union.Left, Union.Top),
      Point(Union.Left, Intersect.Top),
      Point(Union.Left, Intersect.Bottom)) then
      XorRects[0].Right := Intersect.Left;
    if Build(XorRects[1],
      Point(Intersect.Left, Union.Top),
      Point(Intersect.Right, Union.Top),
      Point(Union.Right, Union.Top)) then
      XorRects[1].Bottom := Intersect.Top;
    if Build(XorRects[2],
      Point(Union.Right, Intersect.Top),
      Point(Union.Right, Intersect.Bottom),
      Point(Union.Right, Union.Bottom)) then
      XorRects[2].Left := Intersect.Right;
    if Build(XorRects[3],
      Point(Union.Left, Union.Bottom),
      Point(Intersect.Left, Union.Bottom),
      Point(Intersect.Right, Union.Bottom)) then
      XorRects[3].Top := Intersect.Bottom;
  end;
end;

procedure ModifyExtents(var Extents: Pointer; Index, Amount: Longint;
  Default: Integer);
var
  LongSize, OldSize: LongInt;
  NewSize: Integer;
  I: Integer;
begin
  // Index 为最后一元素的序号
  // Amount 为新元素数减去旧元素数(可能小于0)
  if Amount <> 0 then
  begin
    // OldSize 设为原有元素数,即第 0 个元素
    if not Assigned(Extents) then OldSize := 0
    else OldSize := PIntArray(Extents)^[0];
    // 最后一元素的序号不能小于0, OldSize 应该等于 Index
    if (Index < 0) or (OldSize < Index) then InvalidOp(SIndexOutOfRange);
    // LongSize 为新的元素数,不能小于 0 和越界
    LongSize := OldSize + Amount;
    if LongSize < 0 then InvalidOp(STooManyDeleted)
    else if LongSize >= MaxListSize - 1 then InvalidOp(SGridTooLarge);
    // NewSize 为新的元素数+1
    NewSize := Cardinal(LongSize);
    if NewSize > 0 then Inc(NewSize);
    // 为数组分配内存
    ReallocMem(Extents, NewSize * SizeOf(Integer));
    // 新增元素赋为 Default
    if Assigned(Extents) then
    begin
      I := Index + 1;
      while I < NewSize do
      begin
        PIntArray(Extents)^[I] := Default;
        Inc(I);
      end;
      // 第 0 个元素赋为新的元素个数
      PIntArray(Extents)^[0] := NewSize-1;
    end;
  end;
end;

// 根据 NewSize 修改对应数组(指针),如:FColWidth,FTabStops
procedure UpdateExtents(var Extents: Pointer; NewSize: Longint;
  Default: Integer);
var
  OldSize: Integer;
begin
  // OldSize 设为原有行(列)数,即第 0 个元素
  OldSize := 0;
  if Assigned(Extents) then OldSize := PIntArray(Extents)^[0];
  // Default 为缺省值
  ModifyExtents(Extents, OldSize, NewSize - OldSize, Default);
end;
{
procedure MoveExtent(var Extents: Pointer; FromIndex, ToIndex: Longint);
var
  Extent: Integer;
begin
  if Assigned(Extents) then
  begin
    Extent := PIntArray(Extents)^[FromIndex];
    if FromIndex < ToIndex then
      Move(PIntArray(Extents)^[FromIndex + 1], PIntArray(Extents)^[FromIndex],
        (ToIndex - FromIndex) * SizeOf(Integer))
    else if FromIndex > ToIndex then
      Move(PIntArray(Extents)^[ToIndex], PIntArray(Extents)^[ToIndex + 1],
        (FromIndex - ToIndex) * SizeOf(Integer));
    PIntArray(Extents)^[ToIndex] := Extent;
  end;
end;
}
// 比较两组列宽(行高)数组的值
function CompareExtents(E1, E2: Pointer): Boolean;
va