toolctrlseh.pas

我对ehlib的修改,优化了计算效率,修正了其本身存在的BUG

    procedure UpdateBorderWidth;
  public
    constructor Create(Owner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    function CanFocus: Boolean; {$IFDEF EH_LIB_5} override; {$ENDIF}
    function GetTextHeight: Integer;
    property Color;
    property Ctl3D;
    property Font;
    property ImageList: TCustomImageList read FImageList write SetImageList;
    property IntegralHeight;
    property ItemHeight;
    property RowCount: Integer read FRowCount write SetRowCount;
    property SizeGrip: TSizeGripEh read FSizeGrip;
    property SizeGripResized: Boolean read FSizeGripResized write FSizeGripResized;
    property OnMouseUp;
    property OnGetImageIndex: TListGetImageIndexEventEh read FOnGetImageIndex write FOnGetImageIndex;
  end;

{ TMRUList }
  TFilterMRUItemEventEh = procedure (Sender: TObject; var Accept: Boolean) of object;
  TSetDropDownEventEh = procedure (Sender: TObject) of object;
  TSetCloseUpEventEh = procedure (Sender: TObject; Accept: Boolean) of object;

  TMRUListEh = class(TPersistent)
  private
    FActive: Boolean;
    FAutoAdd: Boolean;
    FCaseSensitive: Boolean;
    FItems: TStrings;
    FLimit: Integer;
    FOnActiveChanged: TNotifyEvent;
    FOnFilterItem: TFilterMRUItemEventEh;
    FOnSetCloseUpEvent: TSetCloseUpEventEh;
    FOnSetDropDown: TSetDropDownEventEh;
    FOwner: TPersistent;
    FRows: Integer;
    FWidth: Integer;
    FCancelIfKeyInQueue: Boolean;
    procedure SetActive(const Value: Boolean);
    procedure SetItems(const Value: TStrings);
    procedure SetLimit(const Value: Integer);
    procedure SetRows(const Value: Integer);
  protected
    FDroppedDown: Boolean;
    procedure UpdateLimit;
  public
    constructor Create(AOwner: TPersistent);
    destructor Destroy; override;
    procedure Add(s: String);
    procedure Assign(Source: TPersistent); override;
    procedure CloseUp(Accept: Boolean); virtual;
    procedure DropDown; virtual;
    function FilterItemsTo(FilteredItems: TStrings; MaskText: String): Boolean;
    property DroppedDown: Boolean read FDroppedDown write FDroppedDown;
    property Width: Integer read FWidth write FWidth;
    property OnActiveChanged: TNotifyEvent read FOnActiveChanged write FOnActiveChanged;
    property OnSetCloseUp: TSetCloseUpEventEh read FOnSetCloseUpEvent write FOnSetCloseUpEvent;
    property OnSetDropDown: TSetDropDownEventEh read FOnSetDropDown write FOnSetDropDown;
    property OnFilterItem: TFilterMRUItemEventEh read FOnFilterItem write FOnFilterItem;
    property CancelIfKeyInQueue: Boolean read FCancelIfKeyInQueue write FCancelIfKeyInQueue default True;
  published
    property AutoAdd: Boolean read FAutoAdd write FAutoAdd default True;
    property Active: Boolean read FActive write SetActive default False;
    property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive default False;
    property Items: TStrings read FItems write SetItems;
    property Limit: Integer read FLimit write SetLimit default 100;
    property Rows: Integer read FRows write SetRows default 7;
  end;

{ TMRUListboxEh }

  TMRUListboxEh = class(TPopupListboxEh)
  private
    FScrollBar: TScrollBar;
    FScrollBarLockMove: Boolean;
    procedure CMChanged(var Message: TCMChanged); message CM_CHANGED;
    procedure CMMouseWheel(var Message: TCMMouseWheel); message CM_MOUSEWHEEL;
    procedure CMSetSizeGripChangePosition(var Message: TMessage); message cm_SetSizeGripChangePosition;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure ScrollBarScrolled(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
    procedure ScrollBarWindowProc(var Message: TMessage);
  public
    constructor Create(Owner: TComponent); override;
    procedure UpdateScrollBar;
    procedure UpdateScrollBarPos;
    property ParentCtl3D;
    property ScrollBar: TScrollBar read FScrollBar;
    property Sorted;
    property OnMouseUp;
  end;

{$IFNDEF EH_LIB_5} // Delphi 4 doesn't have TObjectList but Delphi 8 required

{ TObjectList class }

  TObjectList = class(TList)
  private
    FOwnsObjects: Boolean;
  protected
    function GetItem(Index: Integer): TObject;
    procedure SetItem(Index: Integer; AObject: TObject);
  public
    constructor Create; overload;
    constructor Create(AOwnsObjects: Boolean); overload;

    function Add(AObject: TObject): Integer;
    function Remove(AObject: TObject): Integer;
    function IndexOf(AObject: TObject): Integer;
    function FindInstanceOf(AClass: TClass; AExact: Boolean = True; AStartAt: Integer = 0): Integer;
    procedure Insert(Index: Integer; AObject: TObject);
    property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
    property Items[Index: Integer]: TObject read GetItem write SetItem; default;
  end;

{$ENDIF}

  TDrawButtonControlStyleEh = (bcsDropDownEh, bcsEllipsisEh, bcsUpDownEh,
    bcsCheckboxEh, bcsPlusEh, bcsMinusEh);
  TTreeElementEh = (tehMinusUpDown, tehMinusUp, tehMinusDown,
                   tehPlusUpDown, tehPlusUp, tehPlusDown,
                   tehCrossUpDown, tehCrossUp, tehCrossDown,
                   tehVLine);


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

function GetDefaultFlatButtonWidth: Integer;

var
  FlatButtonWidth: Integer;

type
 TFieldTypes = set of TFieldType;

const
  ftNumberFieldTypes: TFieldTypes = [ftSmallint, ftInteger, ftWord, ftFloat, ftCurrency,
    ftBCD{$IFDEF EH_LIB_6}, ftFMTBcd{$ENDIF}];

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;

procedure DrawImage(DC: HDC; ARect: TRect; Images: TCustomImageList;
  ImageIndex: Integer; Selected: Boolean);
procedure DrawTreeElement(Canvas: TCanvas; ARect: TRect;
  TreeElement: TTreeElementEh; BackDot: Boolean);

function AlignDropDownWindowRect(MasterAbsRect: TRect; DropDownWin: TWinControl; Align: TDropDownAlign): TPoint;
function AlignDropDownWindow(MasterWin, DropDownWin: TWinControl; Align: TDropDownAlign): TPoint;

{$IFNDEF EH_LIB_5}
function Supports(const Instance: IUnknown; const IID: TGUID; out Intf): Boolean; overload;
function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
{$ENDIF}

var
  DefaultCheckBoxWidth, DefaultCheckBoxHeight: Integer;

function AdjustCheckBoxRect(ClientRect: TRect;  Alignment: TAlignment; Layout: TTextLayout): TRect;

function IsDoubleClickMessage(OldPos, NewPos: TPoint; Interval: Longint): Boolean;
function DefaultEditButtonHeight(EditButtonWidth: Integer; Flat: Boolean): Integer;

implementation

uses DBConsts, Math,
  {$IFDEF EH_LIB_6} VDBConsts, Types, {$ENDIF}
  {$IFDEF EH_LIB_7} Themes, UxTheme, {$ENDIF}
  MultiMon;

type
  TWinControlCracker = class(TWinControl) end;
  TControlCracker = class(TControl) end;

{$IFNDEF EH_LIB_5}

function Supports(const Instance: IUnknown; const IID: TGUID; out Intf): Boolean; overload;
begin
  Result := (Instance <> nil) and (Instance.QueryInterface(IID, Intf) = 0);
end;

function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload;
var
  LUnknown: IUnknown;
begin
  Result := (Instance <> nil) and
    ((Instance.GetInterface(IUnknown, LUnknown) and Supports(LUnknown, IID, Intf)) or
    Instance.GetInterface(IID, Intf));
end;

{$ENDIF}

function IsDoubleClickMessage(OldPos, NewPos: TPoint; Interval: Longint): Boolean;
begin
  Result := (Interval <= Longint(GetDoubleClickTime)) and
            (Abs(OldPos.X - NewPos.X) <= GetSystemMetrics(SM_CXDOUBLECLK)) and
            (Abs(OldPos.Y - NewPos.Y) <= GetSystemMetrics(SM_CYDOUBLECLK));
end;

procedure GetCheckSize;
begin
  with TBitmap.Create do
    try
      Handle := LoadBitmapEh(0, OBM_CHECKBOXES);
      DefaultCheckBoxWidth := Width div 4;
      DefaultCheckBoxHeight := Height div 3;
    finally
      Free;
    end;
end;

function AdjustCheckBoxRect(ClientRect: TRect;  Alignment: TAlignment; Layout: TTextLayout): TRect;
var
  CheckWidth, CheckHeight: Integer;
begin
  if (ClientRect.Right - ClientRect.Left) > DefaultCheckBoxWidth
    then CheckWidth := DefaultCheckBoxWidth
    else CheckWidth := ClientRect.Right - ClientRect.Left;

  if (ClientRect.Bottom - ClientRect.Top) > DefaultCheckBoxHeight
    then CheckHeight := DefaultCheckBoxHeight
    else CheckHeight := ClientRect.Bottom - ClientRect.Top;


  Result := ClientRect;

  if (ClientRect.Right - ClientRect.Left) > DefaultCheckBoxWidth then
    case Alignment of
      taRightJustify: Result.Left := Result.Right - CheckWidth;
      taCenter: Result.Left := Result.Left + (ClientRect.Right - ClientRect.Left) shr 1 - CheckWidth shr 1;
    end;
  Result.Right := Result.Left + CheckWidth;

  if (ClientRect.Bottom - ClientRect.Top) > DefaultCheckBoxHeight then
    case Layout of
      tlBottom: Result.Top := Result.Bottom - CheckWidth;
      tlCenter: Result.Top := Result.Top + (ClientRect.Bottom - ClientRect.Top) shr 1 - CheckHeight shr 1;
    end;
  Result.Bottom := Result.Top + CheckHeight;
end;

procedure DrawCheck(DC: HDC; R: TRect; AState: TCheckBoxState; AEnabled, AFlat, ADown, AActive: Boolean);
var
  DrawState, oldRgn: Integer;
  DrawRect: TRect;
//  OldBrushColor: TColor;
//  OldBrushStyle: TBrushStyle;
//  OldPenColor: TColor;
  Rgn, SaveRgn: HRgn;
{$IFDEF EH_LIB_7}
  ElementDetails: TThemedElementDetails;
{$ENDIF}
//  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;
  if ADown then
    DrawState := DrawState or DFCS_PUSHED;
//  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 + 1, Top + 1, Right - 1, Bottom - 1);
    SelectClipRgn(DC, Rgn);
    DeleteObject(Rgn);
  end;
  if AFlat then InflateRect(DrawRect, 1, 1);

{$IFDEF EH_LIB_7}
  if ThemeServices.ThemesEnabled then
  begin
    case AState of
      cbChecked:
        if AEnabled then
          ElementDetails := ThemeServices.GetElementDetails(tbCheckBoxCheckedNormal)
        else
          ElementDetails := ThemeServices.GetElementDetails(tbCheckBoxCheckedDisabled);
      cbUnchecked:
        if AEnabled then
          ElementDetails := ThemeServices.GetElementDetails(tbCheckBoxUncheckedNormal)
        else
          ElementDetails := ThemeServices.GetElementDetails(tbCheckBoxUncheckedDisabled)
      else // cbGrayed
        if AEnabled then
          ElementDetails := ThemeServices.GetElementDetails(tbCheckBoxMixedNormal)
        else
          ElementDetails := ThemeServices.GetElementDetails(tbCheckBoxMixedDisabled);
    end;
    ThemeServices.DrawElement(DC, ElementDetails, R);
  end
  else
{$ENDIF}
    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);
    if AActive
      then FrameRect(DC, DrawRect, GetSysColorBrush(COLOR_BTNFACE))
      else FrameRect(DC, DrawRect, GetSysColorBrush(COLOR_BTNSHADOW));

    { Caller drow in flat mode
    InflateRect(DrawRect, 1, 1);
    if AActive
      then DrawEdge(DC, DrawRect, BDR_SUNKENOUTER, BF_RECT)
      else FrameRect(DC, DrawRect, GetCurrentObject(DC, OBJ_BRUSH));}
  end;
//  end;
end;

const
  DownFlags: array[Boolean] of Integer = (0, DFCS_PUSHED {? or DFCS_FLAT});
  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);
  PressedFlags: array[Boolean] of Integer = (EDGE_RAISED, EDGE_SUNKEN);

procedure DrawEllipsisButton(DC: HDC; ARect: TRect; Enabled, Active, Flat, Pressed: Boolean);
var
  InterP, PWid, W, H: Integer;
  ElRect: TRect;
  Brush, SaveBrush: HBRUSH;
{$IFDEF EH_LIB_7}
  Button: TThemedButton;
  ToolButton: TThemedToolBar;
  Details: TThemedElementDetails;
{$ENDIF}
begin
  ElRect := ARect;

{$IFDEF EH_LIB_7}
  if ThemeServices.ThemesEnabled then
  begin
    if not Enabled then
      Button := tbPushButtonDisabled
    else
      if Pressed then