flatbtns.pas

风格控件。。支持数据库和界面风格优化

unit FlatBtns;

interface

{$I FlatStyle.inc}

uses Windows, Messages, Classes, SysUtils, Controls, Forms, Graphics,
     ExtCtrls, FlatUtils;

const
  InitRepeatPause = 400; // pause before repeat timer (ms)
  RepeatPause     = 100; // pause before hint window displays (ms)

type
  { TDefineSpeed }
  TDefineSpeed = class(TVersionGraphic)
  private
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FTransparent: TTransparentMode;
    TextBounds: TRect;
    GlyphPos: TPoint;
    FNumGlyphs: TNumGlyphs;
    fColorDown: TColor;
    FColorBorder: TColor;
    FColorShadow: TColor;
    fColorFocused: TColor;
    FGroupIndex: Integer;
    FGlyph: TBitmap;
    FDown: Boolean;
    FDragging: Boolean;
    FAllowAllUp: Boolean;
    FLayout: TButtonLayout;
    FSpacing: Integer;
    FMargin: Integer;
    FMouseIn: Boolean;
    FModalResult: TModalResult;
    fColorFlat: TColor;
    procedure SetColors(Index: Integer; Value: TColor);
    procedure UpdateExclusive;
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetDown(Value: Boolean);
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGroupIndex(Value: Integer);
    procedure SetLayout(Value: TButtonLayout);
    procedure SetSpacing(Value: Integer);
    procedure SetMargin(Value: Integer);
    procedure UpdateTracking;
    procedure SetTransparent (const Value: TTransparentMode);
  protected
    FState: TButtonState;
    function  GetPalette: HPALETTE; override;
    procedure Loaded; override;
    procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMParentColorChanged(var Message: TWMNoParams); message CM_PARENTCOLORCHANGED;
    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;
    property Transparent: TTransparentMode read FTransparent write SetTransparent default tmNone;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
    property Color default DefaultFlatColor;
    property ColorFocused: TColor index 0 read fColorFocused write SetColors default DefaultFocusedColor;
    property ColorDown: TColor index 1 read fColorDown write SetColors default DefaultDownColor;
    property ColorBorder: TColor index 2 read FColorBorder write SetColors default DefaultBorderColor;
    property ColorShadow: TColor index 3 read FColorShadow write SetColors default DefaultShadowColor;
    property ColorFlat: TColor index 4 read fColorFlat write SetColors default DefaultFlatColor;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Down: Boolean read FDown write SetDown default False;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphTop;
    property Margin: Integer read FMargin write SetMargin default -1;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
    property ModalResult: TModalResult read FModalResult write FModalResult default 0;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
   {$IFDEF DFS_DELPHI_4_UP}
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
   {$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure MouseEnter;
    procedure MouseLeave;
  end;

  { TTimeBtnState }
  TTimeBtnState = set of (tbFocusRect, tbAllowTimer);
  { TDefineTimer }
  TDefineTimer = class(TDefineSpeed)
  private
    FRepeatTimer: TTimer;
    FTimeBtnState: TTimeBtnState;
    procedure TimerExpired( Sender: TObject);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    property  Cursor default crHandPoint;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property TimeBtnState: TTimeBtnState read FTimeBtnState write FTimeBtnState;
  end;

  { TDefineSpin }
  TDefineSpin = class(TWinControl)
  private
    FUpButton: TDefineTimer;
    FDownButton: TDefineTimer;
    FFocusedButton: TDefineTimer;
    FFocusControl: TWinControl;
    FOnUpClick: TNotifyEvent;
    FOnDownClick: TNotifyEvent;
    function CreateButton: TDefineTimer;
    function GetUpGlyph: TBitmap;
    function GetDownGlyph: TBitmap;
    procedure SetUpGlyph(Value: TBitmap);
    procedure SetDownGlyph(Value: TBitmap);
    function GetUpNumGlyphs: TNumGlyphs;
    function GetDownNumGlyphs: TNumGlyphs;
    procedure SetUpNumGlyphs(Value: TNumGlyphs);
    procedure SetDownNumGlyphs(Value: TNumGlyphs);
    procedure BtnClick(Sender: TObject);
    procedure BtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure SetFocusBtn (Btn: TDefineTimer);
    procedure AdjustSize(var W, H: Integer); reintroduce;// {$IFDEF DFS_COMPILER_4_UP} reintroduce; {$ENDIF}
    procedure WMSize(var Message: TWMSize);  message WM_SIZE;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
  protected
    procedure Loaded; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Notification (AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    property DownGlyph: TBitmap read GetDownGlyph write SetDownGlyph;
    property DownNumGlyphs: TNumGlyphs read GetDownNumGlyphs write SetDownNumGlyphs default 1;
    property FocusControl: TWinControl read FFocusControl write FFocusControl;
    property UpGlyph: TBitmap read GetUpGlyph write SetUpGlyph;
    property UpNumGlyphs: TNumGlyphs read GetUpNumGlyphs write SetUpNumGlyphs default 1;
    property Enabled;
    property Visible;
    property OnDownClick: TNotifyEvent read FOnDownClick write FOnDownClick;
    property OnUpClick: TNotifyEvent read FOnUpClick write FOnUpClick;
  end;

  { TDefineButton }
  TDefineButton = class(TVersionControl)
  private
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FTransparent: TTransparentMode;
    FModalResult: TModalResult;
    TextBounds: TRect;
    GlyphPos: TPoint;
    FNumGlyphs: TNumGlyphs;
    fColorDown: TColor;
    FColorBorder: TColor;
    FColorShadow: TColor;
    fColorFocused: TColor;
    FGroupIndex: Integer;
    FGlyph: TBitmap;
    FDown: Boolean;
    FDragging: Boolean;
    FAllowAllUp: Boolean;
    FLayout: TButtonLayout;
    FSpacing: Integer;
    FMargin: Integer;
    FMouseIn: Boolean;
    FDefault: Boolean;
    fHasFocusFrame: boolean;
    fColorFlat: TColor;
    procedure SetColors(Index: Integer; Value: TColor);
    procedure UpdateExclusive;
    procedure SetGlyph(Value: TBitmap);
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetDown(Value: Boolean);
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGroupIndex(Value: Integer);
    procedure SetLayout(Value: TButtonLayout);
    procedure SetSpacing(Value: Integer);
    procedure SetMargin(Value: Integer);
    procedure UpdateTracking;
    procedure SetDefault(const Value: Boolean);
    procedure SetTransparent (const Value: TTransparentMode);
  protected
    FState: TButtonState;
    function  GetPalette: HPALETTE; override;
    procedure Loaded; override;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
    procedure WMKeyUp(var Message: TWMKeyUp); message WM_KEYUP;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure WMLButtonDblClk(var Message: TWMLButtonDown); message WM_LBUTTONDBLCLK;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;
    procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
    procedure CMParentColorChanged(var Message: TWMNoParams); message CM_PARENTCOLORCHANGED;
    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 SetName(const Value: TComponentName); override;
    property Transparent: TTransparentMode read FTransparent write SetTransparent default tmNone;
    property HasFocusFrame:boolean read fHasFocusFrame write fHasFocusFrame default true;
    property Default: Boolean read FDefault write SetDefault default False;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
    property ColorFocused: TColor index 0 read fColorFocused write SetColors default DefaultFocusedColor;
    property ColorDown: TColor index 1 read fColorDown write SetColors default DefaultDownColor;
    property ColorBorder: TColor index 2 read FColorBorder write SetColors default DefaultBorderColor;
    property ColorShadow: TColor index 3 read FColorShadow write SetColors default DefaultShadowColor;
    property ColorFlat: TColor index 4 read fColorFlat write SetColors default DefaultFlatColor;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Down: Boolean read FDown write SetDown default False;
    property Glyph: TBitmap read FGlyph write SetGlyph;
    property Layout: TButtonLayout read FLayout write SetLayout default blGlyphTop;
    property Margin: Integer read FMargin write SetMargin default -1;
    property NumGlyphs: TNumGlyphs read FNumGlyphs write SetNumGlyphs default 1;
    property TabStop default true;
    property Spacing: Integer read FSpacing write SetSpacing default 4;
    property ModalResult: TModalResult read FModalResult write FModalResult default 0;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure MouseEnter;
    procedure MouseLeave;
  end;
  { TFlatSpeedButton }
  TFlatSpeedButton = class(TDefineSpeed)
  published
    property Transparent;
    property Version;
    property AllowAllUp;
    property ColorFocused;
    property ColorDown;
    property ColorBorder;
    property ColorShadow;
    property ColorFlat;
    property GroupIndex;
    property Down;
    property Caption;
    property Enabled;
    property Font;
    property Glyph;
    property Layout;
    property Margin;
    property NumGlyphs;
    property ModalResult;
    property ParentFont;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Spacing;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
   {$IFDEF DFS_DELPHI_4_UP}
    property Action;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
   {$ENDIF}
  end;
  { TFlatButton }
  TFlatButton = class(TDefineButton)
  published
    property Transparent;
    property HasFocusFrame;
    property Default;
    property AllowAllUp;
    property ColorFocused;
    property ColorDown;
    property ColorBorder;
    property ColorShadow;
    property ColorFlat;
    property GroupIndex;
    property Action;
    property Down;
    property Caption;
    property Enabled;
    property Font;
    property Glyph;
    property Layout;
    property Margin;
    property NumGlyphs;
    property ParentFont;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabStop;
    property TabOrder;
    property Spacing;
    property ModalResult;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseEnter;
    property OnMouseLeave;
   {$IFDEF DFS_DELPHI_4_UP}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
   {$ENDIF}
  end;

implementation

{$R FlatArrow.res}

{ TDefineSpeed }
constructor TDefineSpeed.Create(AOwner: TComponent);
begin
  FGlyph        := TBitmap.Create;
  inherited Create(AOwner);
  ControlStyle  := [csCaptureMouse, csDoubleClicks];
  ParentFont    := True;
  ParentColor   := True;
  fColorFocused := DefaultFocusedColor;
  fColorDown    := DefaultDownColor;
  FColorBorder  := DefaultBorderColor;
  FColorShadow  := DefaultShadowColor;
  FState        := bsUp;
  fColorFlat    := DefaultFlatColor;
  FSpacing      := 4;
  FMargin       := -1;
  FNumGlyphs    := 1;
  FLayout       := blGlyphTop;
  FModalResult  := mrNone;
  FTransparent  := tmNone;
  SetBounds(0, 0, 25, 25);
end;

destructor TDefineSpeed.Destroy;
begin
  FGlyph.Free;
  inherited Destroy;
end;

procedure TDefineSpeed.Paint;
var
  FTransColor: TColor;
  FImageList: TImageList;
  sourceRect, destRect: TRect;
  tempGlyph: TBitmap;
  Offset: TPoint;
begin
  // get the transparent color
  FTransColor := FGlyph.Canvas.Pixels[0, FGlyph.Height - 1];
  Canvas.Font := Self.Font;

  if FState in [bsDown, bsExclusive] then
     Offset := Point(1, 1)
  else
     Offset := Point(0, 0);

  CalcButtonLayout(Canvas, ClientRect, Offset, FLayout, FSpacing,
                   FMargin, FGlyph, FNumGlyphs, Caption, TextBounds, GlyphPos);

  if not Enabled then
  begin
    FState := bsDisabled;
    FDragging := False;
  end
  else
    if FState = bsDisabled then
      if FDown and (GroupIndex <> 0) then
        FState := bsExclusive
      else
        FState := bsUp;

  // DrawBackground
  case FTransparent of
    tmAlways:;
    tmNone:
      begin
        case FState of
          bsUp:
            if FMouseIn then
              Canvas.Brush.Color := fColorFocused
            else
              Canvas.Brush.Color := fColorFlat;
          bsDown:
            Canvas.Brush.Color := fColorDown;
          bsExclusive:
            if FMouseIn then
              Canvas.Brush.Color := fColorFocused
            else
              Canvas.Brush.Color := fColorDown;
          bsDisabled:
            Canvas.Brush.Color := fColorFlat;
        end;
        Canvas.FillRect(ClientRect);
      end;
    tmNotFocused:
      if FMouseIn then
      begin
        case FState of
          bsUp:
            if FMouseIn then
              Canvas.Brush.Color := fColorFocused
            else
              Canvas.Brush.Color := Self.Color;
          bsDown:
            Canvas.Brush.Color := fColorDown;
          bsExclusive:
            if FMouseIn then
              Canvas.Brush.Color := fColorFocused
            else
              Canvas.Brush.Color := fColorDown;
          bsDisabled:
            Canvas.Brush.Color := Self.Color;
        end;
        Canvas.FillRect(ClientRect);
      end;