toolctrlseh.pas

delphi控件类

{*******************************************************}
{                                                       }
{                       EhLib v2.0                      }
{                     Tool controls                     }
{                                                       }
{      Copyright (c) 2001 by Dmitry V. Bolshakov        }
{                                                       }
{*******************************************************}

unit ToolCtrlsEh;

{$I EhLib.Inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
{$IFDEF EH_LIB_6} Variants, {$ENDIF}
  StdCtrls, Mask, Db, DBCtrls, Buttons;

type

  TFieldsArrEh = array of TField;

{ Standard events }

  TButtonClickEventEh = procedure(Sender: TObject; var Handled: Boolean) of object;
  TButtonDownEventEh = procedure(Sender: TObject; TopButton: Boolean;
    var AutoRepeat: Boolean;  var Handled: Boolean) of object;
  TCloseUpEventEh = procedure(Sender: TObject; Accept: Boolean) of object;
  TNotInListEventEh = procedure(Sender: TObject; NewText: String;
    var RecheckInList: Boolean) of object;
  TUpdateDataEventEh = procedure(Sender: TObject; var Handled: Boolean) of object;

{ TDBLookupControl }

  TDBLookupControlEh = class;

  TLookupCtrlDataLinkEh = class(TDataLink)
  private
    FDBLookupControl: TDBLookupControlEh;
  protected
    procedure ActiveChanged; override;
    procedure FocusControl(Field: TFieldRef); override;
    procedure LayoutChanged; override;
    procedure RecordChanged(Field: TField); override;
  public
    constructor Create;
  end;

  TLookupCtrlListLinkEh = class(TDataLink)
  private
    FDBLookupControl: TDBLookupControlEh;
  protected
    procedure ActiveChanged; override;
    procedure DataSetChanged; override;
    procedure LayoutChanged; override;
  public
    constructor Create;
  end;

  TDBLookupControlEh = class(TCustomControl)
  private
    FDataFieldName: string;
    FDataFields: TFieldsArrEh;
    FDataLink: TLookupCtrlDataLinkEh;
    FHasFocus: Boolean;
    FKeyFieldName: string;
    FKeyFields: TFieldsArrEh;
    FKeyValue: Variant;
    FListActive: Boolean;
    FListField: TField;
    FListFieldIndex: Integer;
    FListFieldName: string;
    FListFields: TList;
    FListLink: TLookupCtrlListLinkEh;
    FLookupMode: Boolean;
    FLookupSource: TDataSource;
    FMasterFieldNames:String;
    FMasterFields: TFieldsArrEh;
    FSearchText: string;
    function GetDataField: TField;
    function GetDataSource: TDataSource;
    function GetKeyFieldName: string;
    function GetListSource: TDataSource;
    function GetReadOnly: Boolean;
    procedure CheckNotCircular;
    procedure CheckNotLookup;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure DataLinkRecordChanged(Field: TField);
    procedure SetDataFieldName(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetKeyFieldName(const Value: string);
    procedure SetKeyValue(const Value: Variant);
    procedure SetListFieldName(const Value: string);
    procedure SetListSource(Value: TDataSource);
    procedure SetLookupMode(Value: Boolean);
    procedure SetReadOnly(Value: Boolean);
    procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
    procedure WMKillFocus(var Message: TMessage); message WM_KILLFOCUS;
    procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS;
  protected
    function CanModify: Boolean; virtual;
    function GetBorderSize: Integer; virtual;
    function GetTextHeight: Integer; virtual;
    function LocateKey: Boolean; virtual;
    procedure KeyValueChanged; virtual;
    procedure ListLinkDataChanged; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure ProcessSearchKey(Key: Char); virtual;
    procedure SelectKeyValue(const Value: Variant); virtual;
    procedure UpdateDataFields; virtual;
    procedure UpdateListFields; virtual;
    property DataField: string read FDataFieldName write SetDataFieldName;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property HasFocus: Boolean read FHasFocus;
    property KeyField: string read GetKeyFieldName write SetKeyFieldName;
    property KeyValue: Variant read FKeyValue write SetKeyValue;
    property ListActive: Boolean read FListActive;
    property ListField: string read FListFieldName write SetListFieldName;
    property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0;
    property ListFields: TList read FListFields;
    property ListLink: TLookupCtrlListLinkEh read FListLink;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property ParentColor default False;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
    property SearchText: string read FSearchText write FSearchText;
    property TabStop default True;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Field: TField read GetDataField;
  end;

{ TDBLookupListBoxEh }

  TDBLookupListBoxEh = class(TDBLookupControlEh)
  private
    FBorderStyle: TBorderStyle;
    FKeyFields: TFieldsArrEh;
    FKeySelected: Boolean;
    FListField: TField;
    FLockPosition: Boolean;
    FMousePos: Integer;
    FPopup: Boolean;
    FRecordCount: Integer;
    FRecordIndex: Integer;
    FRowCount: Integer;
    FSelectedItem: string;
    FShowTitles: Boolean;
    FTimerActive: Boolean;
    FTracking: Boolean;
    function  GetKeyIndex: Integer;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure SelectCurrent;
    procedure SelectItemAt(X, Y: Integer);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetRowCount(Value: Integer);
    procedure SetShowTitles(const Value: Boolean);
    procedure StopTimer;
    procedure StopTracking;
    procedure TimerScroll;
    procedure UpdateScrollBar;
    procedure WMCancelMode(var Message: TMessage); message WM_CANCELMODE;
    procedure WMTimer(var Message: TMessage); message WM_TIMER;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  protected
    FTitleHeight: Integer;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure KeyValueChanged; override;
    procedure ListLinkDataChanged; 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 Paint; override;
    procedure UpdateListFields; override;
  public
    constructor Create(AOwner: TComponent); override;
    function ExecuteAction(Action: TBasicAction): Boolean; override;
    function UpdateAction(Action: TBasicAction): Boolean; override;
    function UseRightToLeftAlignment: Boolean; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property KeyValue;
    property SelectedItem: string read FSelectedItem;
    property ShowTitles:Boolean read FShowTitles write SetShowTitles;
  published
    property Align;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
    {$IFDEF EH_LIB_5}
    property OnContextPopup;
    {$ENDIF}
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Color;
    property Ctl3D;
    property DataField;
    property DataSource;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property ImeMode;
    property ImeName;
    property KeyField;
    property ListField;
    property ListFieldIndex;
    property ListSource;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property RowCount: Integer read FRowCount write SetRowCount stored False;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

{ TSizeGripEh }

  TSizeGripPostion = (sgpTopLeft,sgpTopRight,sgpBottomRight,sgpBottomLeft);
  TSizeGripChangePosition = (sgcpToLeft,sgcpToRight,sgcpToTop,sgcpToBottom);

  TSizeGripEh = class(TCustomControl)
  private
    FInitScreenMousePos:TPoint;
    FInternalMove: Boolean;
    FOldMouseMovePos:TPoint;
    FParentRect:TRect;
    FParentResized:TNotifyEvent;
    FPosition: TSizeGripPostion;
    FTriangleWindow: Boolean;
    function GetVisible: Boolean;
    procedure SetPosition(const Value: TSizeGripPostion);
    procedure SetTriangleWindow(const Value: Boolean);
    procedure SetVisible(const Value: Boolean);
    procedure WMMove(var Message: TMessage); message WM_MOVE;
  protected
    procedure CreateWnd; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    procedure ParentResized; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    procedure ChangePosition(NewPosition: TSizeGripChangePosition);
    procedure UpdatePosition;
    property Position:TSizeGripPostion read FPosition write SetPosition default sgpBottomRight;
    property TriangleWindow:Boolean read FTriangleWindow write SetTriangleWindow default True;
    property Visible: Boolean read GetVisible write SetVisible;
    property OnParentResized:TNotifyEvent read FParentResized write FParentResized;
  end;

{ TPopupDataListEh }
const
    cm_SetSizeGripChangePosition = WM_USER + 100;

type
  TPopupDataListEh = class(TDBLookupListBoxEh)
  private
    FOnUserKeyValueChange: TNotifyEvent;
    FSizeGrip:TSizeGripEh;
    FSizeGripResized:Boolean;
    FUserKeyValueChanged:Boolean;
    function CheckNewSize(var NewWidth, NewHeight: Integer): Boolean;
    procedure CMSetSizeGripChangePosition(var Message:TMessage); message cm_SetSizeGripChangePosition;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
    procedure WMMouseActivate(var Message: TMessage); message WM_MOUSEACTIVATE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyValueChanged; 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;
  public
    constructor Create(AOwner: TComponent); override;
    property SizeGrip: TSizeGripEh read FSizeGrip;
    property SizeGripResized:Boolean read FSizeGripResized write FSizeGripResized;
    property OnUserKeyValueChange: TNotifyEvent read FOnUserKeyValueChange write FOnUserKeyValueChange;
  end;


  TDrawButtonControlStyleEh = (bcsDropDownEh, bcsEllipsisEh, bcsUpDownEh, bcsCheckboxEh);
  procedure PaintButtonControlEh(DC: HDC;ARect:TRect;ParentColor:TColor;
               Style:TDrawButtonControlStyleEh; DownButton:Integer;
               Flat,Active,Enabled:Boolean; State: TCheckBoxState);

  function GetDefaultFlatButtonWidth:Integer;

var
  FlatButtonWidth:Integer;

procedure GetFieldsProperty(List: TList; DataSet: TDataSet;
   Control: TComponent; const FieldNames: String); overload;

function GetFieldsProperty(DataSet: TDataSet; Control: TComponent;
   const FieldNames: String):TFieldsArrEh; overload;

procedure DataSetSetFieldValues(DataSet: TDataSet; Fields: String; Value:Variant);

function VarEquals(const V1, V2: Variant): Boolean;

var UseButtonsBitmapCache:Boolean = True;

procedure ClearButtonsBitmapCache;

implementation

uses DBConsts {$IFDEF EH_LIB_6} ,VDBConsts {$ENDIF};

procedure DrawCheck(DC: HDC; R: TRect; AState: TCheckBoxState; AEnabled, AFlat: Boolean);
var
  DrawState,oldRgn: Integer;
  DrawRect: TRect;
//  OldBrushColor: TColor;
//  OldBrushStyle: TBrushStyle;
//  OldPenColor: TColor;
  Rgn, SaveRgn: HRgn;
//  Brush,SaveBrush: HBRUSH;
begin
  SaveRgn := 0;
  oldRgn := 0;
  DrawRect := R;
  with DrawRect do
    if (Right - Left) > (Bottom - Top) then
    begin
     Left := Left + ((Right - Left) - (Bottom - Top)) div 2;
     Right := Left + (Bottom - Top);
    end else if (Right - Left) < (Bottom - Top) then
    begin
     Top := Top + ((Bottom - Top) - (Right - Left)) div 2;
     Bottom := Top + (Right - Left);
    end;
  case AState of
    cbChecked:
      DrawState := DFCS_BUTTONCHECK or DFCS_CHECKED;
    cbUnchecked:
      DrawState := DFCS_BUTTONCHECK;
    else // cbGrayed
      DrawState := DFCS_BUTTON3STATE or DFCS_CHECKED;
  end;
  if not AEnabled then
    DrawState := DrawState or DFCS_INACTIVE;
//  with Canvas do
//  begin
    if AFlat then
    begin
      { Remember current clipping region }
      SaveRgn := CreateRectRgn(0,0,0,0);
      oldRgn := GetClipRgn(DC, SaveRgn);
      { Clip 3d-style checkbox to prevent flicker }
      with DrawRect do
        Rgn := CreateRectRgn(Left + 2, Top + 2, Right - 2, Bottom - 2);
      SelectClipRgn(DC, Rgn);
      DeleteObject(Rgn);
    end;
    if AFlat then InflateRect(DrawRect,1,1);
    DrawFrameControl(DC, DrawRect, DFC_BUTTON, DrawState);
    if AFlat then
    begin
      //SelectClipRgn(Handle, SaveRgn);
      if oldRgn = 0 then
        SelectClipRgn(DC, 0)
      else
        SelectClipRgn(DC, SaveRgn);
      DeleteObject(SaveRgn);
      { Draw flat rectangle in-place of clipped 3d checkbox above }
      InflateRect(DrawRect,-1,-1);
      FrameRect(DC,DrawRect,GetSysColorBrush(COLOR_BTNSHADOW));

      InflateRect(DrawRect,1,1);
      FrameRect(DC,DrawRect,GetCurrentObject(DC,OBJ_BRUSH));
    end;
//  end;
end;

const
  DownFlags : array [Boolean] of Integer = (0,DFCS_PUSHED);
  FlatFlags : array [Boolean] of Integer = (0,DFCS_FLAT);
  EnabledFlags : array [Boolean] of Integer = (DFCS_INACTIVE,0);
  IsDownFlags: array [Boolean] of Integer = (DFCS_SCROLLUP, DFCS_SCROLLDOWN);

procedure DrawEllipsisButton(DC: HDC; ARect: TRect; Enabled, Active, Flat, Pressed: Boolean);
var InterP,PWid,W,H:Integer;
    ElRect:TRect;
    Brush,SaveBrush: HBRUSH;
begin
  ElRect := ARect;
  Brush := GetSysColorBrush(COLOR_BTNFACE);
  if Flat then
  begin
    Windows.FillRect(DC, ElRect, Brush);
    InflateRect(ElRect,-1,-1)
  end else
  begin
    DrawEdge(DC, ElRect, EDGE_RAISED, BF_RECT or BF_MIDDLE or FlatFlags[Pressed]);
    InflateRect(ElRect,-2,-2);
    Windows.FillRect(DC, ElRect, Brush);
  end;
  InterP := 2;
  PWid := 2;
  W := ElRect.Right - ElRect.Left ;//+ Ord(not Active and Flat);
  if W < 12 then InterP := 1;