aligrid.pas

一个STRINGGRID 控件,比原DELPHI自带的STRINGGRID 功能强大

    procedure ReadPropCell(Reader: TReader);
    procedure ReadPropCol(Reader: TReader);
    procedure ReadPropRow(Reader: TReader);
    procedure ReadPropFixedCol(Reader: TReader);
    procedure ReadPropFixedRow(Reader: TReader);

    procedure WritePropCell(Writer: TWriter);
    procedure WritePropCol(Writer: TWriter);
    procedure WritePropRow(Writer: TWriter);
    procedure WritePropFixedCol(Writer: TWriter);
    procedure WritePropFixedRow(Writer: TWriter);

    function ReadPropColRow(Reader: TReader; list:TList):boolean;
    function ReadPropCellInt(Reader: TReader; list:TList):boolean;
    procedure WritePropColRow(Writer: TWriter; count: longint; list:TList);
    procedure WritePropCellInt(Writer: TWriter; x,y:longint; list:TList);
  (*@\\\0000000201*)
  (*@/// +  The other properties *)
  protected
    f_nextcell: Boolean;
    f_drawselect: boolean;
    f_nextcell_edit, f_nextcell_tab: T_nextcell;
    f_lastcell_edit, f_lastcell_tab: t_lastcell;
    f_fixedcols, f_fixedrows: longint;
    procedure SetDrawselect(value: boolean);
  published
    property AutoEditNextCell: boolean read f_nextcell write f_nextcell default false;
    property NextCellEdit: T_nextcell read f_nextcell_edit write f_nextcell_edit default nc_rightdown;
    property NextCellTab:  T_nextcell read f_nextcell_tab  write f_nextcell_tab  default nc_rightdown;
    property AfterLastCellEdit: t_lastcell read f_lastcell_edit write f_lastcell_edit default lc_newcolrow;
    property AfterLastCellTab:  t_lastcell read f_lastcell_tab  write f_lastcell_tab  default lc_first;
    property DrawSelection: boolean read f_drawselect write SetDrawselect default true;
  (*@\\\0000000D01*)
  (*@/// +  Sorting *)
  private
    f_compare_col: TCompareFunction;
    f_compare_row: TCompareFunction;
  protected
    fSortMethod: TSortFunction;
    procedure DoSortBubble(ColRow,Min,Max: longint; ByColumn,ascending:boolean);
    procedure DoSortQuick(ColRow,Min,Max: longint; ByColumn,ascending:boolean);
  public
    function CompareColString(Sender: TObject; Column, Row1,Row2: longint):t_relation;
    function CompareRowString(Sender: TObject; RowNr, Col1,Col2: longint):t_relation;
    function CompareColInteger(Sender: TObject; Column, Row1,Row2: longint):t_relation;
    function CompareRowInteger(Sender: TObject; RowNr, Col1,Col2: longint):t_relation;
    procedure SortColumn(Column: longint; Ascending:boolean);
    procedure SortRow(Rownumber: longint; Ascending:boolean);
  published
    property OnCompareRow: TCompareFunction read f_compare_row write f_compare_row;
    property OnCompareCol: TCompareFunction read f_compare_col write f_compare_col;
  (*@\\\000000110C*)
  (*@/// +  Events for col and row resizing *)
  protected
    fwidthschanged: TNotifyEvent;
    fheightschanged: TNotifyEvent;
    procedure ColWidthsChanged; override;
    procedure RowHeightsChanged; override;
  public
    procedure AdjustRowHeight(ARow:longint);
    procedure AdjustColWidth(ACol:longint);
    procedure AdjustRowHeights;
    procedure AdjustColWidths;
  published
    property OnColWidthsChanged: TNotifyEvent read fwidthschanged write fwidthschanged;
    property OnRowHeightsChanged: TNotifyEvent read fheightschanged write fheightschanged;
  { Suggested by Olav Lindkjolen <[e-mail]> }
  protected
    FAutoAdjustLastCol: Boolean;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure SetAutoAdjustLastCol(Value: Boolean);
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
    procedure SetGridLineWidthNew(Value: Integer);
  public
    procedure AdjustLastCol;
    function GetTotalWidth:Longint;
    function GetTotalHeight:Longint;
  published
    property AutoAdjustLastCol:boolean read FAutoAdjustLastCol write SetAutoAdjustLastCol default false;
    { A virtual SetGridLineWidth would make this be easier... }
    property GridLineWidth write SetGridLineWidthNew;
  (*@\\\0000000601*)
  (*@/// -  The main procedure DrawCell *)
  protected
    f_ondrawcellpar: TCellDrawEvent;
    procedure DrawCell(ACol,ARow:Longint; ARect:TRect; AState:TGridDrawState); override;
    procedure DrawCellBack(ACol,ARow:Longint; var ARect:TRect; AState:TGridDrawState); virtual;
    procedure DrawCellText(ACol,ARow:Longint; var ARect:TRect; AState:TGridDrawState); virtual;
    procedure DrawCellCombo(ACol,ARow:Longint; var ARect:TRect; AState:TGridDrawState); virtual;
  { published }
    (* Last minute access to the text parameters, maybe useful *)
    property OnDrawCellParameters: TCellDrawEvent read f_ondrawcellpar write f_ondrawcellpar;
    procedure Paint;  override;
  (*@\\\0000000A01*)
  (*@/// +  Clicks on the fixed columns/rows *)
  protected
    f_fixedcolclick: TColEvent;
    f_fixedrowclick: TRowEvent;
    procedure MouseDown(Button:TMouseButton; Shift:TShiftState; X,Y:Integer); override;
  published
    property OnFixedColClick:TColEvent read f_fixedcolclick write f_fixedcolclick;
    property OnFixedRowClick:TRowEvent read f_fixedRowclick write f_fixedRowclick;
  (*@\\\*)
  (*@/// +  Allow the scrollbar to act immidiatly *)
  protected
    f_dyn_scroll: boolean;
  public
    procedure WMHScroll(var Msg:TWMHScroll); message wm_hscroll;
    procedure WMVScroll(var Msg:TWMVScroll); message wm_vscroll;
    function VerticalScrollBarVisible: boolean;
    function HorizontalScrollBarVisible: boolean;
  published
    property RedrawWhileScroll:boolean read f_dyn_scroll write f_dyn_scroll default false;
  (*@\\\0000000601*)
  (*@/// +  Cut 'n' Paste *)
  protected
    F_PasteEditableOnly: boolean;
    f_cutnpaste: boolean;
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMCopy(var Message: TMessage); message WM_COPY;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
  public
    property PasteEditableOnly: boolean read F_PasteEditableOnly write F_PasteEditableOnly;
    property AllowCutnPaste: boolean read f_cutnpaste write f_cutnpaste;
  (*@\\\000000090C*)
  (*@/// !  Comboboxes *)
  protected
    function CellHasCombobox(ACol,ARow:longint):boolean;
  (*@\\\*)
    end;
  (*@\\\0000000F01*)

(*@/// Internal routines and objects, just put here to let the be used by aligredi too *)
type
  (*@/// TMyFont = class(TFont) *)
  TMyFont = class(TFont)
  protected
    procedure Changed; override;
  public
    HasChanged: boolean;
    end;
  (*@\\\0000000503*)
  (*@/// TMyBrush = class(TBrush) *)
  TMyBrush = class(TBrush)
  protected
    procedure Changed; override;
  public
    HasChanged: boolean;
    end;
  (*@\\\*)


function GetItemCell(ACol,ARow: longint; List:TList):Pointer;
function SetItemCell(ACol,ARow: longint; List:TList; value:Pointer):pointer;
function GetItemCol(ACol: longint; List:TList):Pointer;
function SetItemCol(ACol: longint; List:TList; value:Pointer):pointer;

procedure WriteFont(Writer: TWriter; v:TFont);
function ReadFont(Reader: TReader):TFont;
procedure WriteBrush(Writer: TWriter; v:TBrush);
function ReadBrush(Reader: TReader):TBrush;
(*@\\\0000000201*)
(*@\\\0000002202*)
(*@/// implementation *)
implementation

(*$ifdef delphi_1 *)
const
  DT_END_ELLIPSIS = $8000;
(*$endif *)

const
  Col_before_Row = true;
  ComboDropDownWidth = 16;

(*@/// Some internal utility procedures for handling the lists *)
{ Clean my internal lists for the three kinds of data }

(*@/// procedure cleanlist(List:TList; size:integer); *)
procedure cleanlist(List:TList; size:integer);
var
  i:longint;
begin
  if list<>NIL then begin
    for i:=0 to List.Count-1 do
      if List.Items[i] <> NIL then
        Freemem(List.Items[i],size);
    end;
  end;
(*@\\\0000000A07*)
(*@/// procedure cleanlist_pstring(List:TList); *)
procedure cleanlist_pstring(List:TList);
var
  i:longint;
begin
  if list<>NIL then begin
    for i:=0 to List.Count-1 do
      if List.Items[i] <> NIL then
        DisposeStr(List.Items[i]);
    end;
  end;
(*@\\\*)
(*@/// procedure cleanlist_object(List:TList); *)
procedure cleanlist_object(List:TList);
var
  i:longint;
begin
  if list<>NIL then begin
    for i:=0 to List.Count-1 do
      TObject(List.Items[i]).Free;
    end;
  end;
(*@\\\*)
(*@\\\*)
(*@/// Reading and writing TFont and TBrush objects to the DFM *)
{ I HATE Borland - here a simple Writer.WriteProperties() would do, but these }
{ idiots have made this method private and only the trivial ones are public.  }
{ They invent such powerfull mechanisms to access properties at design time   }
{ and then they destroy any way to use these for advanced components :-(      }
{ So I have to write every property and not only those that are changed       }
{ from the default, and I have to do the assumption that they won't change    }
{ the TFontStyles and TFontPitch types as that would run this into great      }
{ problems. And of course what to do with a beast like a TButton instead of   }
{ a TFont - then the mechanism below won't be enough.                         }
{ So anyone knowing a better way to do it is greatly welcome!                 }

(*@/// procedure WriteFont(Writer: TWriter; v:TFont); *)
{ I HATE Borland - here a simple Writer.WriteProperties() would do, but these }
{ idiots have made this method private and only the trivial ones are public.  }
{ They invent such powerfull mechanisms to access properties at design time   }
{ and then they destroy any way to use these for advanced components :-(      }
{ So I have to write every property and not only those that are changed       }
{ from the default, and I have to do the assumption that they won't change    }
{ the TFontStyles and TFontPitch types as that would run this into great      }
{ problems. And of course what to do with a beast like a TButton instead of   }
{ a TFont - then the mechanism below won't be enough.                         }
{ So anyone knowing a better way to do it is greatly welcome!                 }

procedure WriteFont(Writer: TWriter; v:TFont);
var
  t: TFontStyles;
begin
  Writer.WriteInteger(v.Color);
  Writer.WriteInteger(v.height);
  Writer.WriteString(v.name);
{ WriteEnum is missing, have to write as an integer }
  Writer.WriteInteger(cardinal(v.Pitch));
{ The WriteSet is also missing, again only savable as an integer }
  t:=v.Style;
{ and why can't I cast a set to an integer directly ? }
  Writer.WriteInteger(cardinal(pointer(@t)^));
  end;
(*@\\\0000000C0B*)
(*@/// function ReadFont(Reader: TReader):TFont; *)
function ReadFont(Reader: TReader):TFont;
var
  t: integer;
begin
{ The same work-around as in WriteFont }
  result:=NIL;
  try
    result:=TMyFont.Create;
    result.Color:=Reader.ReadInteger;
    result.height:=Reader.ReadInteger;
    result.name:=Reader.ReadString;
    result.pitch:=TFontPitch(Reader.ReadInteger);
    t:=reader.readinteger;
    result.style:=TFontStyles(pointer(@t)^);
  except
    result.free;
    RAISE;
    end;
  end;
(*@\\\*)
(*@/// procedure WriteBrush(Writer: TWriter; v:TBrush); *)
{ The same comment as in WriteFont applies here }

procedure WriteBrush(Writer: TWriter; v:TBrush);
begin
  Writer.WriteInteger(v.Color);
{ WriteEnum is missing, have to write as an integer }
  Writer.WriteInteger(cardinal(v.Style));
  end;
(*@\\\*)
(*@/// function ReadBrush(Reader: TReader):TBrush; *)
function ReadBrush(Reader: TReader):TBrush;
begin
  result:=NIL;
  try
    result:=TMyBrush.Create;
    result.Color:=Reader.ReadInteger;
    result.style:=TBrushStyle(Reader.ReadInteger);
  except
    result.free;
    RAISE;
    end;
  end;
(*@\\\0000000B09*)
(*@\\\*)

(*@/// TCellProperties      = class(TObject) *)
const
  prop_end      = 0;
  prop_align    = 1;
  prop_wrap     = 2;
  prop_edit     = 3;
  prop_brush    = 4;
  prop_selbrush = 5;
  prop_font     = 6;
  prop_selfont  = 7;

(*@/// procedure copy_font(var tgt: TFont; src: TFont); *)
procedure copy_font(var tgt: TFont; src: TFont);
begin
  if src=NIL then begin
    tgt.free;
    tgt:=NIL;
    end
  else begin
    if tgt=NIL then
      tgt:=TMyFont.Create;
    tgt.assign(src);
    end;
  end;
(*@\\\0000000301*)
(*@/// procedure copy_brush(var tgt: TBrush; src: TBrush); *)
procedure copy_brush(var tgt: TBrush; src: TBrush);
begin
  if src=NIL then begin
    tgt.free;
    tgt:=NIL;
    end
  else begin
    if tgt=NIL then
      tgt:=TMyBrush.create;
    tgt.assign(src);
    end;
  end;
(*@\\\0000000120*)

{ TCellProperties }
(*@/// constructor TCellProperties.Create(Grid:TStringAlignGrid); *)
constructor TCellProperties.Create(Grid:TStringAlignGrid);
begin
  inherited create;
  align:=alDefault;
  wordwrap:=ww_default;
  f_grid:=grid;
  end;
(*@\\\0000000123*)
(*@/// destructor TCellProperties.destroy; *)
destructor TCellProperties.destroy;
begin
  brush.free;
  selBrush.free;