crgrid.pas

医院信息管理系统 后台采用ORACLE

//////////////////////////////////////////////////
//  CRControls
//  Copyright (c) 2000-2001 Core Lab. All right reserved.
//  CRGrid component
//////////////////////////////////////////////////

unit CRGrid;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, DB, StdCtrls, Menus, DBAccess, ComCtrls;

{$I CRGrid.inc}

type
  TCRDBGrid = class;

{ TCRColumn }

  TSortOrder = (soNone, soAsc, soDesc);
  TSummaryMode = (smNone, smSum, smAvr, smMax, smMin);

  TOnMemoClick = procedure (Sender: TObject; Column: TColumn) of object;

  TCRColumnTitle = class(TColumnTitle)
  private
    function GetCaption: string;
    function IsCaptionStored: boolean;

  protected
    procedure SetCaption(const Value: string);

  published
    property Caption: string read GetCaption write SetCaption stored IsCaptionStored;
  end;

  TCRColumn = class (TColumn)
  private
    FMinWidth: integer;
    FTotalString: string;
    FTotalLoaded: boolean;
    FSummaryMode: TSummaryMode;
    FTotalFloat: extended;
    FTotalInt: int64;
    FFloatDigits: integer;
    FFloatPrecision: integer;
    FFloatFormat: TFloatFormat;
    FFilterExpression: string;
    FTableSpacePercent: double;

    function GetSortOrder: TSortOrder;
    procedure SetSortOrder(Value: TSortOrder);
    function GetSortSequence: integer;
    procedure SetSortSequence(Value: integer);
    function GetTotalString: string;
    procedure SetSummaryMode(Value: TSummaryMode);
    procedure SetFloatDigits(const Value: integer);
    procedure SetFloatFormat(const Value: TFloatFormat);
    procedure SetFloatPrecision(const Value: integer);
    procedure SetFilterExpression(const Value: string);
    procedure SetTableSpacePercent(const Value: double);
    procedure SetWidth(const Value: integer);
    function GetWidth: integer;
{$IFDEF VER5P}
    procedure ReadData(Reader: TReader); // for compatible with old resource
{$ENDIF}

  protected
    function CreateTitle: TColumnTitle; override;
{$IFDEF VER5P}
    procedure DefineProperties(Filer: TFiler); override; // for compatible with old resource
{$ENDIF}

  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property TableSpacePercent: double read FTableSpacePercent write SetTableSpacePercent;
    procedure ResetTotal;
    procedure LoadTotal;
    procedure SetTotal;
    function CanBeSorted: boolean;
    function GetFilterExpression(const RawFilter: string): string;
    procedure ChangedTitle(Rebild: boolean);
    property TotalString: string read GetTotalString write FTotalString;

  published
    property Width: integer read GetWidth write SetWidth;
    property FilterExpression: string read FFilterExpression write SetFilterExpression;
    property MinWidth: integer read FMinWidth write FMinWidth default 30;
    property SortOrder: TSortOrder read GetSortOrder write SetSortOrder default soNone;
    property SortSequence: integer read GetSortSequence write SetSortSequence default 0;
    property SummaryMode: TSummaryMode read FSummaryMode write SetSummaryMode default smNone;
    property FloatFormat: TFloatFormat read FFloatFormat write SetFloatFormat default ffGeneral;
    property FloatPrecision: integer read FFloatPrecision write SetFloatPrecision default 0;
    property FloatDigits: integer read FFloatDigits write SetFloatDigits default 0;
  end;

  TCRDBGridColumns = class(TDBGridColumns)
  private
    function GetColumn(Index: Integer): TCRColumn;
    procedure SetColumn(Index: Integer; Value: TCRColumn);
  public
    property Items[Index: Integer]: TCRColumn read GetColumn write SetColumn; default;
  end;

{ TGridTitleEdit }

  TCRGridTitleEdit = class(TCustomStaticText)
  private
    FCRDBGrid: TCRDBGrid;
    FEdit: TEdit;
    FAsFilter: boolean;
    FActiveColumn: TColumn;
    FFilterExpressions: array of string;
    FEditingFilter: boolean;

    procedure SetCRDBGrid(const Value: TCRDBGrid);
    procedure FEditKeyPress(Sender: TObject; var Key: char);
    procedure FEditKeyDown(Sender: TObject; var Key: word;
      Shift: TShiftState);
    procedure FEditChange(Sender: TObject);
    procedure FEditExit(Sender: TObject);
    procedure ProcessEdit;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure GotoUpperCell;
    procedure GotoLowerCell;
    procedure GotoNextCell;
    procedure GotoPrevCell;
    procedure SetEditingFilter(const Value: boolean);
    procedure PostFilter;

  protected
    procedure PaintWindow(DC: HDC); override;
    procedure KeyDown(var Key: word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: integer); override;
    procedure DoExit; override;
    procedure WMChar(var Message: TWMChar); message WM_CHAR;

  public
    constructor Create(AOwner: TComponent); override;
    procedure SetFocus; override;
    procedure ActivateAt(ARect: TRect; ActiveColumn: TColumn; AsFilter: boolean);
    procedure SetClientRect(ARect: TRect);
    procedure StartEdit;
    procedure StopEdit(AcceptChanges: boolean);

    property CRDBGrid: TCRDBGrid read FCRDBGrid write SetCRDBGrid;
    property Edit: TEdit read FEdit;
    property EditingFilter: boolean read FEditingFilter write SetEditingFilter;
  end;

{ TMemoEditorForm }

  TMemoEditorForm = class (TCustomForm)
  private
    FMemo: TMemo;
    FOKBtn: TButton;
    FCancelBtn: TButton;
    FReadOnly: boolean;
    FCheckBox: TCheckBox;
    procedure SetReadOnly(const Value: boolean);
    procedure MemoKeyDown(Sender: TObject; var Key: word;
      Shift: TShiftState);
    procedure CheckBoxClick(Sender: tobject);
  public
    constructor Create(AOwner: TComponent); override;
    function CloseQuery: boolean; override;
    property ReadOnly: boolean read FReadOnly write SetReadOnly;
  end;

{ TCRDBGrid }

  TCRDBGridOptionEx = (dgeEnableSort, dgeFilterBar, dgeLocalFilter, dgeRecordCount,
    dgeSearchBar, dgeStretch, dgeSummary);
  TCRDBGridOptionsEx = set of TCRDBGridOptionEx;

  TGridDrawStateEx = set of (geHighlight, geActiveRow, geMultiSelected);

  TGetCellParamsEvent = procedure (Sender: TObject; Field: TField;
    AFont: TFont; var Background: TColor; State: TGridDrawState; StateEx: TGridDrawStateEx) of object;

  PSortColInfo = ^TSortColInfo;
  TSortColInfo = record
    Index: integer;
    Desc: boolean;
  end;

  TIndicatorColButton = (icbNone, icbMenu, icbFilter, icbSearch);

  TCRDBGrid = class(TCustomDBGrid)
  private
    FDefaultDrawing: boolean;
    FOptionsEx: TCRDBGridOptionsEx;
    FSoft: boolean;
    FOnGetCellParams: TGetCellParamsEvent;
    FLoaded: boolean;
    FExecSizing: boolean;
    FExecSorting: boolean;
    FExecColAjust: boolean;
    FSortInfo: TList;
    FActiveRowSelected: boolean;
    FTitleButtonDown: integer;
    FOldTitleButtonDown: integer;
    FCellButtonDown: integer;
    FCellButtonRow: integer;
    FCellButtonCol: integer;
    FCellButtonPressed: boolean;
    FCellButtonRect: TRect;
    FCellButtonBRect: TRect;
    FTotalYOffset: integer;
    FOnMemoClick: TOnMemoClick;
    FLevelDelimiterChar: char;
    FIndicatorColBtnDown: TIndicatorColButton;
    FOldIndicatorColBtnDown: TIndicatorColButton;
    FPopupMenu: TPopupMenu;
    CRGridTitleEdit: TCRGridTitleEdit;
    FStatusRect: TRect;
    FFiltered: boolean;
    FContinueEditingFilter: boolean;
    FMemoWidth: integer;
    FMemoHeight: integer;
    FMemoWordWrap: boolean;

    procedure SetOptionsEx(Value: TCRDBGridOptionsEx);
    procedure UpdateHeaderHeight;
    procedure RecordChanged(Field: TField);
    procedure DrawButton(X,Y: integer; State: boolean);
    function  IsOnButton(X, Y: integer): boolean;
    function  GetButtonRect(Cell: TGridCoord): TRect;
    procedure SetLevelDelimiterchar(const Value: char);
    procedure WMSetCursor(var Message: TWMSetCursor); message WM_SetCursor;
    function CalcSearchBar(Column: TColumn): TRect;
    function CalcFilterBar(Column: TColumn): TRect;
    function MouseInFilterBar(X, Y: integer; Column: TColumn = nil): boolean;
    function MouseInFilterEdit(X, Y: integer; Column: TColumn = nil): boolean;
    function MouseInSortBar(X, Y: integer; Column: TColumn = nil): boolean;
    function MouseInSortEdit(X,Y: integer;Column: TColumn = nil): boolean;
    function MouseInLowerstLevel(X, Y: integer; Column: TColumn = nil): boolean;
    procedure DoOnMemoClick(Column: TColumn);

    procedure DrawTitleBarCell(Canvas: TCanvas; Column: TColumn; Rect: TRect; Text: string);
    procedure DrawTitleIndicatorCell(Canvas: TCanvas; ARect: TRect);
    function GetIndicatorButton(X,Y: integer): TIndicatorColButton;
    procedure IndicatorClick(Button: TIndicatorColButton; X, Y: integer);
    procedure BuildMenu;
    procedure FilteredItemClick(Sender: TObject);
    procedure FilterItemClick(Sender: TObject);
    procedure SearchItemClick(Sender: TObject);
    procedure CalcTableSpacePercent;
    procedure SetFiltered(const Value: boolean);
    procedure UpdateRowCount;
    function GetColumns: TCRDBGridColumns;
    procedure SetColumns(const Value: TCRDBGridColumns);

  protected
    FHeaderHeight: integer;

    function GetClientRect: TRect; override;
    procedure Loaded; override;

    function CreateColumns: TDBGridColumns; override;

    procedure Reorder;
    function  FindSortColInfo(Index: integer; var SortNum: integer): PSortColInfo;

    procedure ColWidthsChanged; override;
    procedure Resize; override;
    procedure ResizeColumns(ResizedColumn: integer = -1);
    function  EndColumnDrag(var Origin, Destination: integer;
      const MousePt: TPoint): boolean; override;

    procedure DrawColumnCell(const Rect: TRect; DataCol: integer;
      Column: TColumn; State: TGridDrawState); override;
    procedure GetCellProps(Field: TField; AFont: TFont; var Background: TColor;
      State: TGridDrawState; StateEx:TGridDrawStateEx); dynamic;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;

    procedure KeyDown(var Key: word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: integer); override;

    procedure LinkActive(Value: boolean); override;
    procedure Paint;override;
    procedure ResetTotals;
    procedure LoadTotals;
    function CanEditShow: boolean; override;
    procedure TopLeftChanged; override;
    procedure DoExit; override;

  public
    procedure ActivateSearchEdit(Column: TColumn);
    procedure ActivateFilterEdit(Column: TColumn);
    function GetGridSize: integer;
    procedure LayoutChanged; override;
    constructor Create(Owner: TComponent); override;
    procedure DataChanged; //override;
    destructor Destroy; override;

    procedure ClearSorting;
    procedure ClearFilters;

    property Canvas;
    property SelectedRows;
    procedure CalcTitleLevel(Level: integer; var aRect: TRect);
    function GetTitleLevel(Level: integer): TRect;
    procedure ApplyFilter;
    procedure AdjustColumns;
    property Col;
    property Row;
    property TopRow;
    property LeftCol;


  published
    property DefaultDrawing: boolean read FDefaultDrawing write FDefaultDrawing
      default True;
    property LevelDelimiterChar: char read FLevelDelimiterchar write SetLevelDelimiterchar default '|';
    property Filtered: boolean read FFiltered write SetFiltered default True;
    property OptionsEx: TCRDBGridOptionsEx read FOptionsEx write SetOptionsEx
      default [dgeEnableSort, dgeLocalFilter, dgeRecordCount];
    property OnMemoClick: TOnMemoClick read FOnMemoClick write FOnMemoClick;
    property OnGetCellParams: TGetCellParamsEvent read FOnGetCellParams
     write FOnGetCellParams;

    property Align;
    property Anchors;
    property BiDiMode;
    property BorderStyle;
    property Color;
    property Columns: TCRDBGridColumns read GetColumns write SetColumns stored False;
    property Constraints;
    property Ctl3D;
    property DataSource;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FixedColor;
    property Font;
    property ImeMode;
    property ImeName;
    property Options;
    property ParentBiDiMode;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property TitleFont;
    property Visible;
    property OnCellClick;
    property OnColEnter;
    property OnColExit;
    property OnColumnMoved;
    property OnDrawDataCell;  { obsolete }
    property OnDrawColumnCell;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEditButtonClick;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp; 
    property OnStartDock;
    property OnStartDrag;
    property OnTitleClick;
  end;

resourcestring
  SFiltered = 'Filtered';
  SFilterBar = 'Filter bar';
  SSearchBar = 'Search bar';
  sWordWrap = 'Word Wrap'; 
  SOK = '&OK';
  SCancel = '&Cancel';
  SClose = '&Close';
  fmtModifiedWarning = 'Field "%s" is modified. Save?';

implementation

uses
  Math, CRParser;

{$R *.res}

var
  bmpSortAsc: TBitmap;
  bmpSortDesc: TBitmap;
  DrawBitmap: TBitmap;
  bmpFilter: TBitmap;
  bmpSearch: TBitmap;
  bmpMenu: TBitmap;
  bmpActiveFilter: TBitmap;
  bmpEditMode: TBitmap;
  UserCount: integer;

type
  TInthernalEdit = class(TEdit)
  end;

  _TCustomGrid = class(TCustomGrid)
  end;

function GetCaptionDepth(const Str: string; Delim: char): integer;
var