sbuttoncontrol.pas

AlphaControls是一个Delphi标准控件的集合

unit sButtonControl;
interface

{$I sDefs.inc}
{$R+}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, sStyleUtil,
    sMessages, sConst, ExtCtrls, sPanel, sGraphUtils, commctrl, Buttons, Imglist,
    sUtils, ActnList, comctrls, Menus, math, sDefaults;

type
  TsButtonControl = Class;

  TsButtonActionLink = class(TControlActionLink)
  protected
    FClient: TsButtonControl;
    procedure AssignClient(AClient: TObject); override;
    function IsCheckedLinked: Boolean; override;
    procedure SetChecked(Value: Boolean); override;
    function IsImageIndexLinked: Boolean; override;
    procedure SetImageIndex(Value: Integer); override;
    function IsCaptionLinked: Boolean; override;
    procedure SetCaption(const Value: String); override;
  end;

  TFadeTimer = class(TTimer)
  private
    FOwner: TsButtonControl;
    procedure SetDirection(const Value: TFadeDirection);
  public
    FDirection : TFadeDirection;
    constructor Create(AOwner: TComponent); override;
    procedure FadeUp;
    procedure FadeDown;
    procedure Timer; override;
    procedure TimerAction(Sender : TObject);
    procedure ToEnd;
    property Direction : TFadeDirection read FDirection write SetDirection;
  end;

  TsButtonControl = class(TCustomControl)
  private
    FMargin: integer;
    FNumGlyphs: integer;
    FOnMouseEnter: TNotifyEvent;
    FOnMouseLeave: TNotifyEvent;
    FImages: TCustomImageList;
    FImagesGrayed: TCustomImageList;
    FImagesDisabled: TCustomImageList;
    FImageChangeLink: TChangeLink;
    FDisabledGlyphKind: TsDisabledGlyphKind;
    FAlignment: TAlignment;
    FDisabledKind: TsDisabledKind;

    procedure SetMargin(const Value: integer);
    procedure SetNumGlyphs(const Value: integer);
    procedure SetImages(const Value: TCustomImageList);
    function GetCustomImageList : TCustomImageList;
    procedure SetDisabledGlyphKind(const Value: TsDisabledGlyphKind);
    procedure SetAlignment(const Value: TAlignment);
    procedure SetDisabledKind(const Value: TsDisabledKind);
  protected
    FShowCaption: boolean;
    FSpacing: integer;
    FImageIndex : integer;
    FAutoSize: boolean;
    FDropdownMenu: TPopupMenu;
    FGrayed: boolean;
    FBlend: integer;
    FAllowAllUp : boolean;
    FCheck : boolean;
    FGroupIndex : integer;
    FBevelWidth : integer;
    FButtonStyle : TToolButtonStyle;
    FDown : boolean;
    FLayout : TButtonLayout;
    FsStyle : TsActiveBGStyle;
    FDropDowmMenu : TPopupMenu;
    FOldBounds : TRect;

    procedure SetLayout(const Value: TButtonLayout);
    procedure SetBevelWidth(const Value: integer);
    procedure SetSpacing(const Value: integer);
    procedure SetDown(const Value: boolean);
    procedure SetShowCaption(const Value: boolean);
    procedure SetButtonStyle(const Value: TToolButtonStyle);
    procedure SetDropdownMenu(const Value: TPopupMenu);
    procedure SetGrayed(const Value: boolean);
    procedure SetBlend(const Value: integer);
    procedure SetAllowAllUp(const Value: boolean);
    procedure SetImageIndex(const Value: integer);
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure ImageListChange(Sender: TObject);

    function GetActionLinkClass: TControlActionLinkClass; override;
    function AddedWidth: integer; dynamic;
    procedure AddedPainting; dynamic;
    procedure MouseDown (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp (Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
{$IFDEF DELPHI6UP}
    procedure SetAutoSize(Value: boolean); override;
{$ELSE}
    procedure SetAutoSize(Value: boolean);
{$ENDIF}
    procedure WndProc (var Message: TMessage); override;
    procedure WMMouseEnter (var Message: TWMMouse); message CM_MOUSEENTER;
    procedure WMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE;
    procedure WMEraseBkGND (var Message: TWMPaint); message WM_ERASEBKGND;
    procedure CreateWnd; override;
    procedure SetCanvasProps; dynamic;
  public
    FTextLayout : integer;
    DroppedDown : boolean;

    OldBmp : TBitmap;
    FadeLevel : integer;
    Direction : boolean;
    FadeTimer : TFadeTimer;
    procedure PaintNewBmp;

    procedure StartFadeIn;
    procedure StartFadeOut;
    procedure StopFading;

    procedure AdjustSize; override;
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Invalidate; override;
    procedure Paint; override;
    procedure DrawContents; dynamic;
    procedure DrawGlyph; dynamic;

    procedure CreateParams(var Params: TCreateParams); override;
    procedure AfterConstruction; override;
    procedure Loaded; override;

    procedure PaintSkinBorder(index : integer);
    procedure PaintBtnBorder;
    function GlyphWidth : integer; dynamic;
    function GlyphHeight : integer; dynamic;
    function TextRectSize : TSize;
    function MaxTextLen : integer;
    procedure DoDrawText(var Rect: TRect; Flags: Longint); dynamic;
    procedure DrawCaption;
    function ImgRect : TRect;
    function CaptionRect : TRect;

    property Blend : integer read FBlend write SetBlend default 0;
    property Grayed : boolean read FGrayed write SetGrayed default False;
    property Down : boolean read FDown write SetDown default False;
    property ButtonStyle : TToolButtonStyle read FButtonStyle write SetButtonStyle default tbsButton;
    property DropdownMenu: TPopupMenu read FDropdownMenu write SetDropdownMenu;
    property AllowAllUp : boolean read FAllowAllUp write SetAllowAllUp default False;
    property GroupIndex : integer read FGroupIndex write FGroupIndex default 0;
    property ImageIndex : integer read FImageIndex write SetImageIndex default -1;
    property Layout : TButtonLayout read FLayout write SetLayout;
    property ShowCaption: boolean read FShowCaption write SetShowCaption default True;
    property Spacing : integer read FSpacing write SetSpacing default 4;
    property NumGlyphs : integer read FNumGlyphs Write SetNumGlyphs default DefNumGlyphs;

    property Alignment : TAlignment read FAlignment write SetAlignment default taCenter;
    property DisabledGlyphKind : TsDisabledGlyphKind read FDisabledGlyphKind write SetDisabledGlyphKind default DefDisabledGlyphKind;
    property Images : TCustomImageList read FImages write SetImages;
    property ImagesGrayed : TCustomImageList read FImagesGrayed write FImagesGrayed;
    property ImagesDisabled : TCustomImageList read FImagesDisabled write FImagesDisabled;
  published
    property AutoSize : boolean read FAutoSize write SetAutoSize default False;
    property BevelWidth : integer read FBevelWidth write SetBevelWidth default 2;
    property DisabledKind : TsDisabledKind read FDisabledKind write SetDisabledKind default DefDisabledKind;
    property sStyle : TsActiveBGStyle read FsStyle write FsStyle;
    property Action;
    property Align;
    property Anchors;
    property Caption;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    property Margin : integer read FMargin write SetMargin default 0;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnCanResize;
    property OnClick;
    property OnConstrainedResize;
    property OnContextPopup;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseEnter : TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave : TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDock;
    property OnStartDrag;
  end;

implementation

uses sStyleSimply, sBorders, sCustomButton, sMaskData, sAlphaGraph;

//function IsDebuggerPresent(): Boolean; external 'kernel32.dll';

var
  MenuVisible : boolean = False;

{ TToolButtonActionLink }

procedure TsButtonActionLink.AssignClient(AClient: TObject);
begin
  inherited AssignClient(AClient);
  FClient := AClient as TsButtonControl;
end;

function TsButtonActionLink.IsCaptionLinked: Boolean;
begin
  Result := inherited IsCaptionLinked and
    (FClient.Caption = (Action as TCustomAction).Caption);
end;

function TsButtonActionLink.IsCheckedLinked: Boolean;
begin
  Result := inherited IsCheckedLinked and
    (FClient.Down = (Action as TCustomAction).Checked);
end;

function TsButtonActionLink.IsImageIndexLinked: Boolean;
begin
  Result := inherited IsImageIndexLinked{ and
    (FClient.ImageIndex = (Action as TCustomAction).ImageIndex)};
end;

procedure TsButtonActionLink.SetCaption(const Value: String);
begin
  if IsCaptionLinked and (FClient.Caption <> Value) then FClient.Caption := Value;
end;

procedure TsButtonActionLink.SetChecked(Value: Boolean);
begin
  if IsCheckedLinked then FClient.Down := Value;
end;

procedure TsButtonActionLink.SetImageIndex(Value: Integer);
begin
  if IsImageIndexLinked then FClient.ImageIndex := Value;
end;

{ TsButtonControl }

procedure TsButtonControl.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  inherited ActionChange(Sender, CheckDefaults);
  if not Assigned(Images) and Assigned(TAction(Action).ActionList.Images) then begin
    Images := TAction(Action).ActionList.Images;
  end;
  if ImageIndex <> TAction(Action).ImageIndex then begin
    ImageIndex := TAction(Action).ImageIndex;
  end;
  if not CheckDefaults then begin
    if Caption <> TAction(Action).Caption then begin
      Caption := TAction(Action).Caption;
      sStyle.Invalidate;
    end;
    if Hint <> TAction(Action).Hint then begin
      Hint := TAction(Action).Hint;
    end;
  end;
end;

constructor TsButtonControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csOpaque, csCaptureMouse, csDoubleClicks, csSetCaption];
  sStyle := TsActiveBGStyle.Create(TWinControl(Self));
  sStyle.COC := COC_TsButtonControl;
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
  FAlignment := taCenter;

  FDisabledGlyphKind := DefDisabledGlyphKind;
  FButtonStyle := tbsButton;
  Height := 22;
  Width := 84;
  FImageIndex := -1;
  FSpacing := 3;
  FMargin := 0;
  FBevelWidth := 2;
  TabStop := False;
  FShowCaption := True;
  FGrayed := False;
  FBlend := 0;
  FAllowAllUp := False;
  FGroupIndex := 0;
  FNumGlyphs := DefNumGlyphs;

  OldBmp := TBitmap.Create;
  OldBmp.PixelFormat := pf24Bit;

  FadeTimer := TFadeTimer.Create(Self);
  FadeTimer.Enabled := False;

  FDisabledKind := DefDisabledKind;
end;

destructor TsButtonControl.Destroy;
begin
  FadeTimer.Enabled := False;
  if Assigned(FadeTimer) then FreeAndNil(FadeTimer);

  if Assigned(OldBmp) then FreeAndNil(OldBmp);
  if Assigned(FsStyle) then FreeAndNil(FsStyle);
  if Assigned(FImageChangeLink) then FreeAndNil(FImageChangeLink);
  inherited Destroy;
end;

procedure TsButtonControl.DrawContents;
begin
  case ButtonStyle of
    tbsDivider: begin
      sStyle.PaintBevel(sStyle.FCacheBmp, Rect((Width - BevelWidth) div 2,
                           BevelWidth,
                           (Width - BevelWidth) div 2 + 3 * BevelWidth,
                           Height - BevelWidth), BevelWidth, sStyle.ActualBevel, sStyle.SoftControl);
    end;
    tbsSeparator: begin
    end
    else begin
      if sStyle.RegionChanged then begin
        sStyle.FRegion := 0;
        sStyle.FRegion := CreateRectRgn(0, 0, Width, Height);
      end;
      if IsValidSkinIndex(sStyle.SkinIndex) then begin
        if IsValidImgIndex(sStyle.BorderIndex) then begin
          PaintSkinBorder(sStyle.BorderIndex);
        end
        else begin
          sStyle.PaintBorder(sStyle.FCacheBmp.Canvas.Handle, Rect(ClientRect.Left, ClientRect.Top, ClientRect.Right - AddedWidth, ClientRect.Bottom));
        end;
      end
      else if sStyle.BtnEffects.MaskedBorders.Enabled then begin
        PaintBtnBorder;
      end
      else begin
        sStyle.PaintBorder(sStyle.FCacheBmp.Canvas.Handle, Rect(ClientRect.Left, ClientRect.Top, ClientRect.Right - AddedWidth, ClientRect.Bottom));
      end;

      if sStyle.RegionChanged then begin
        SetWindowRgn(Handle, sStyle.FRegion, True);
        sStyle.RegionChanged := False;
      end;
      DrawGlyph;
      DrawCaption;
    end;
  end;
end;

procedure TsButtonControl.DrawGlyph;
var
  IRect : TRect;
  IList: TCustomImageList;
  Enbl, GrayWant : boolean;
  Bmp : TBitmap;
  MaskColor: TsColor;
  procedure PrepareGlyph; begin
    Bmp.Width := IList.Width;
    Bmp.Height := IList.Height;
    Bmp.PixelFormat := pf24bit;
    if Ilist.BkColor = clNone then begin
      Bmp.Canvas.Brush.Color := clFuchsia
    end
    else begin
      Bmp.Canvas.Brush.Color := Ilist.BkColor;
    end;
    Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
    IList.GetBitmap(ImageIndex, Bmp);
  end;
begin
  IList := GetCustomImageList;
  Enbl := Enabled or (IList = ImagesDisabled);
  GrayWant := Grayed and (IList = Images);
  IRect := ImgRect;
  if Assigned(IList) and (ImageIndex > -1) then begin
    Bmp := TBitmap.Create;
    try
      PrepareGlyph;
      if not Enbl then begin
        if dgGrayed in DisabledGlyphKind then begin
          GrayScale(Bmp);
        end;
        if dgBlended in DisabledGlyphKind then begin
          MaskColor := TsColor(Bmp.Canvas.Pixels[0, Bmp.Height - 1]);
          BlendTransRectangle(sStyle.FCacheBmp, IRect.Left, IRect.Top, Bmp,
                                Rect(0,
                                     0,
                                     Bmp.Width,
                                     Bmp.Height),
                                0.5, MaskColor);
        end
        else begin
          MaskColor := TsColor(Bmp.Canvas.Pixels[0, Bmp.Height - 1]);
          CopyTransBitmaps(sStyle.FCacheBmp, Bmp, IRect.Left, IRect.Top, MaskColor);
        end;
      end
      else begin


        if not sStyle.ControlIsActive and GrayWant then begin
          GrayScale(Bmp);
        end;

        MaskColor := TsColor(Bmp.Canvas.Pixels[0, Bmp.Height - 1]);

        if not sStyle.ControlIsActive and (Blend > 0) then begin
          BlendTransRectangle(sStyle.FCacheBmp, IRect.Left, IRect.Top, Bmp,
                              Rect(0,
                                   0,
                                   Bmp.Width,
                                   Bmp.Height),
                              Blend / 100, MaskColor);
        end
        else begin
          CopyTransBitmaps(sStyle.FCacheBmp, Bmp, IRect.Left, IRect.Top, MaskColor);
        end;
      end;
    finally
      FreeAndNil(Bmp);
    end;
  end;
end;

function TsButtonControl.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TsButtonActionLink;
end;

procedure TsButtonControl.Invalidate;
begin
  sStyle.FCacheBMP.Canvas.Font.Assign(Font);
  if Assigned(Parent) and not(csDestroying in ComponentState)
     and not(csLoading in ComponentState) then begin
    AdjustSize;
  end;
  if (csDesigning in ComponentState) and Assigned(FsStyle) then begin
    if not RestrictDrawing then FsStyle.BGChanged := True;
  end;
  inherited;
end;

procedure TsButtonControl.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
  p : TPoint;
  c : TMouse;
  i : integer;
begin
  inherited;
  c := nil;
  StopFading;
  if (Button = mbLeft) and Enabled then begin
    case ButtonStyle of
      tbsDropDown : begin
        if (X > Width - AddedWidth) and Assigned(DropDownMenu) then begin
          if not MenuVisible then begin
            MenuVisible := True;
            DroppedDown := True;
            if not RestrictDrawing then sStyle.BGChanged := True;
            Repaint;
            p := ClientToScreen(Point(0, Height + 1));
            DropDownMenu.Popup(p.X, p.Y);
            if not PtInRect(Rect(p.x, p.y - Height - 1, p.x + Width, p.y - 1), c.CursorPos) then begin