dsfancybutton.pas

componete para dar presentacion a tus aplicaciones es indispensable para una buena presentacion

unit DsFancyButton;

{-----------------------------------------------------
 DsFancyButton Release 3.0 for Delphi 3/4/5/6/7/8/2005
 Copyright (c) 1999-2006 by Djoko Susilo
 e-mail: [e-mail]
 URL   : http://vtpmanufacturing.com
 ----------- Q14 Project Feb-99 R1.0 -----------------
 Files needed to install:
 DsFancyButton.pas (this file)
 DsFancyButton.dcr (resource for icon)
 -----------------------------------------------------
 R1.1 10-Nov-99:
   -Gradient process using region function
 R1.1 22-May-00:
   -Using better region routine to release memory
 R2.0 10-Jan-01:
   -Shape constant of shRoundRect is removed.
    Rounded rectangle can be set through CornerRadius setting.
   -Add property glyph and its layout.
    Max. glyph number is 3 (glyph 1=enable  2=disable  3=pressed)
   -Better button pressing effect.
 R2.1 16-Feb-01:
   -Add hover color when mouse moves over the button.
   update 15-Mar-01:
   -Fix caption position when font is changed.
   update 17-May-01:
   -Add one more glyph to response mouse move
    (glyph 1=enable  2=disable  3=pressed  4=pointed).
   -Remove property TransparentColor. Use standard method in
    checking transparent color (left-bottom corner of glyph).
 R2.1 08-May-01:
   -Restructure the codes to implement property groupings, so setting
    values become much more easier.
   -Redefine button pressing effect. Pressing color is now
    automatically using dimmed color of its face color.
    Greatly improved pressing effect!
   update 14-Apr-02:
    free occupied resources
 R2.2 13-Jul-02:
   -add hovering effect to button face
   -now it has better appearance
 R3.0 01-Jan-06:
   -Redesigned button face, looks smooth.
   -Properties FaceColor and FrameColor are deleted.
    Button face color now is using property Color.
   -Again, different pressing effect.
   -Add property GlyphStyle  -->raised, lowered, plain.
   -Button size is free, no limitation.
 -----------------------------------------------
 thanks to:
   - Danny Indra <[e-mail]>
   - Parker Nolen <[e-mail]>
   - David Hooper <[e-mail]>
   - Hermann Husemann <[e-mail]>
   - Laercio Santana <[e-mail]>
 for feedback, suggestions and improvement notes.
 -----------------------------------------------}


{$R-}
{$B-}
{$H+}   {--always use this compiler directive----}

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Math;

type
  {--Fancy options--}
  TTextStyle = (txPlain, txLowered, txRaised, txShadowed);
  TBtnShape = (btnCapsule, btnOval, btnRectangle);
  TFrameStyle = (fmNone, fmGradient);
  TDsEffect = class(TPersistent)
  private
    FBtnShape: TBtnShape;
    FCornerRadius: Integer;
    FFrameWidth: Integer;
    FHoverColor: TColor;
    FTextStyle: TTextStyle;
    FFrameStyle: TFrameStyle;
    FOnEffectChange: TNotifyEvent;
    procedure DoChanges;
    procedure SetBtnShape(Value: TBtnShape);
    procedure SetCornerRadius(Value: Integer);
    procedure SetFrameStyle(Value: TFrameStyle);
    procedure SetFrameWidth(Value: Integer);
    procedure SetHoverColor(Value: TColor);
    procedure SetTextStyle(Value: TTextStyle);
  public
  published
    property FrameStyle: TFrameStyle read FFrameStyle write SetFrameStyle;
    property FrameWidth: Integer read FFrameWidth write SetFrameWidth;
    property HoverColor: TColor read FHoverColor write SetHoverColor;
    property Shape: TBtnShape read FBtnShape write SetBtnShape;
    property CornerRadius: Integer read FCornerRadius write SetCornerRadius;
    property TextStyle: TTextStyle read FTextStyle write SetTextStyle;
    property OnEffectChange: TNotifyEvent read FOnEffectChange write FOnEffectChange;
  end;

  {--Glyph options--}
  TBmpLayout = (lyLeft, lyTop, lyRight, lyBottom, lyCenter);
  TGlyphStyle = (gsNormal, gsRaised, gsLowered);
  TDsGlyph = class(TPersistent)
  private
    FBmpGlyph: TBitmap;
    FBmpLayout: TBmpLayout;
    FGlyphsNum: Byte;
    FGlyphSpace: Integer;
    FOnGlyphChange: TNotifyEvent;
    FGlyphStyle: TGlyphStyle;
    procedure DoChanges;
    procedure SetBmpLayout(Value: TBmpLayout);
    procedure SetBmpGlyph(ABmpGlyph: TBitmap);
    procedure SetGlyphsNum(Value: Byte);
    procedure SetGlyphSpace(Value: Integer);
    procedure SetGlyphStyle(const Value: TGlyphStyle);
  published
    property Glyph: TBitmap read FBmpGlyph write SetBmpGlyph;
    property GlyphStyle: TGlyphStyle read FGlyphStyle write SetGlyphStyle;
    property Layout: TBmpLayout read FBmpLayout write SetBmpLayout;
    property Number: Byte read FGlyphsNum write SetGlyphsNum;
    property Distance: Integer read FGlyphSpace write SetGlyphSpace;
    property OnGlyphChange: TNotifyEvent read FOnGlyphChange write FOnGlyphChange;
  end;

  {--Fancy button--}
  TDsFancyButton = class(TGraphicControl)
  private
    FEffect: TDsEffect;
    FGlyphs: TDsGlyph;
    FIsDown: Boolean;
    FInRegion: Boolean;
    FBmpWidth: Integer;
    FGlyphToDraw: Integer;
    FGlyphL, FGlyphT: Integer;
    FTransparentColor: TColor;
    FTextL, FTextT: Integer;

    procedure CMMouseLeave(var AMsg: TMessage); message CM_MOUSELEAVE;
    procedure CMEnabledChanged(var message: TMessage);
              message CM_ENABLEDCHANGED;
    procedure CMTextChanged(var message: TMessage);
              message CM_TEXTCHANGED;
    procedure CMDialogChar(var message: TCMDialogChar);
              message CM_DIALOGCHAR;
  protected
    procedure UpdateChanges(Sender: TObject);
    procedure Click; override;
    procedure DrawButtonFace;
    procedure DrawButtonBorder;
    procedure DrawGlyph;
    procedure WriteCaption;
    procedure LayoutSetting;
    procedure Paint; override;
    function  IsInRegion(X, Y: Integer): Boolean;
    function  ColorLevel(BaseColor: TColor; Value: Integer): TColor;
    procedure Additional3DEffect;
    procedure MouseUp(Button: TMouseButton;
              Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton;
              Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Anchors;     //delete this line if you find compiler error
    property Constraints; //delete this line if you find compiler error
    property Color;
    property Caption;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FancyEffects: TDsEffect read FEffect write FEffect;
    property Glyphs: TDsGlyph read FGlyphs write FGlyphs;
    property Font;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;

    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
  end;

procedure Register;

implementation

{----------------------------}
{--Fancy Options-------------}
{----------------------------}

procedure TDsEffect.SetHoverColor(Value: TColor);
begin
  FHoverColor:=Value;
  DoChanges;
end;

procedure TDsEffect.SetBtnShape(Value: TBtnShape);
begin
  FBtnShape:=Value;
  DoChanges;
end;

procedure TDsEffect.SetCornerRadius(Value: Integer);
begin
  FCornerRadius:=Value;
  if FCornerRadius<0 then FCornerRadius:=0;
  if FCornerRadius>145 then FCornerRadius:=145;
  DoChanges;
end;

procedure TDsEffect.SetFrameWidth(Value: Integer);
begin
  FFrameWidth:=Value;
  if FFrameWidth<3 then FFrameWidth:=3;
  if FFrameWidth>14 then FFrameWidth:=14;
  DoChanges;
end;

procedure TDsEffect.SetTextStyle(Value: TTextStyle);
begin
  FTextStyle:=Value;
  DoChanges;
end;

procedure TDsEffect.SetFrameStyle(Value: TFrameStyle);
begin
  FFrameStyle:=Value;
  DoChanges;
end;

procedure TDsEffect.DoChanges;
begin
  if Assigned(FOnEffectChange) then FOnEffectChange(Self);
end;


{----------------------------}
{--Glyph Options-------------}
{----------------------------}
procedure TDsGlyph.SetBmpGlyph(ABmpGlyph: TBitmap);
begin
  FBmpGlyph.Assign(ABmpGlyph);
  DoChanges;
end;

procedure TDsGlyph.SetGlyphStyle(const Value: TGlyphStyle);
begin
  FGlyphStyle:=Value;
  DoChanges;
end;

procedure TDsGlyph.SetBmpLayout(Value: TBmpLayout);
begin
  FBmpLayout:=Value;
  DoChanges;
end;

procedure TDsGlyph.SetGlyphsNum(Value: Byte);
begin
  FGlyphsNum:=Value;
  if FGlyphsNum<1 then FGlyphsNum:=1;
  if FGlyphsNum>4 then FGlyphsNum:=4;
  DoChanges;
end;

procedure TDsGlyph.SetGlyphSpace(Value: Integer);
begin
  FGlyphSpace:=Value;
  if FGlyphSpace<1 then FGlyphSpace:=0;
  DoChanges;
end;

procedure TDsGlyph.DoChanges;
begin
  if Assigned(FOnGlyphChange) then FOnGlyphChange(Self);
end;


{----------------------------}
{--Fancy Button--------------}
{----------------------------}
constructor TDsFancyButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle:=[csClickEvents, csCaptureMouse, csSetCaption];
  Enabled:=True;
  
  FEffect:=TDsEffect.Create;
  with FEffect do
  begin
    Color:=clBtnFace;
    FFrameWidth:=6;
    FHoverColor:=clBlue;
    FBtnShape:=btnRectangle;
    FCornerRadius:=3;
    FTextStyle:=txLowered;
    FFrameStyle:=fmGradient;
    OnEffectChange:=UpdateChanges;
  end;

  FGlyphs:=TDsGlyph.Create;
  with FGlyphs do
  begin
    FBmpGlyph:=TBitmap.Create;
    FBmpLayout:=lyLeft;
    FGlyphsNum:=1;
    FGlyphSpace:=0;
    OnGlyphChange:=UpdateChanges;
  end;

  FBmpWidth:=0;
  FGlyphToDraw:=1;
  FIsDown:=False;
  Height:=25;
  Visible:=True;
  Width:=97;
end;

destructor TDsFancyButton.Destroy;
begin
  if Assigned(FGlyphs.Glyph) then FGlyphs.Glyph.Destroy;
  FGlyphs.Free;
  FEffect.Free;
  inherited Destroy;
end;

procedure TDsFancyButton.Paint;
var Dia: Integer;
begin
  FBmpWidth:=FGlyphs.Glyph.Width div FGlyphs.Number;

  Canvas.Font:=Self.Font;

  {--draw base color--}
  if FEffect.FFrameStyle=fmGradient then
  begin
    if FIsDown then
    begin
      Canvas.Brush.Color:=ColorLevel(Color, -65);
      Canvas.Pen.Color:=ColorLevel(Color, -5);
    end
    else
    begin
      Canvas.Brush.Color:=Color;
      Canvas.Pen.Color:=Color;
    end;
    case FEffect.Shape of
      btnOval:
         Canvas.Ellipse(0, 0, Width-1, Height-1);
      btnCapsule:
         begin
           if Width<Height then Dia:=Width else Dia:=Height;
           Canvas.RoundRect(0, 0, Width-1, Height-1, Dia, Dia)
         end;
      btnRectangle:
         begin
           Dia:=2*FEffect.FCornerRadius;
           Canvas.RoundRect(0, 0, Width-1, Height-1, Dia, Dia);
         end;
    end
  end;

  Canvas.Brush.Style:=bsClear;
  if FEffect.FrameStyle=fmNone then DrawButtonBorder
  else DrawButtonFace;

  LayoutSetting;
  if FBmpWidth>0 then DrawGlyph;

  WriteCaption;
end;

function TDsFancyButton.IsInRegion(X, Y: Integer): Boolean;
var Dia: Integer;
    MRgn: HRgn;
begin
  Result:=False;
  case FEffect.Shape of
    btnRectangle:
      begin
        Dia:=2*FEffect.CornerRadius;
        MRgn:=CreateRoundRectRgn(0, 0, Width, Height, Dia, Dia);
      end;
    btnCapsule:
      begin
        if Width<Height then Dia:=Width else Dia:=Height;
        MRgn:=CreateRoundRectRgn(0, 0, Width, Height, Dia, Dia);
      end;
    btnOval: MRgn:=CreateEllipticRgn(0, 0, Width, Height);
  end; //case

  try
    if PtInRegion(MRgn, X, Y) then Result:=True;
  finally
    DeleteObject(MRgn);
  end;
end;

procedure TDsFancyButton.DrawButtonBorder;
var Dia: Integer;
begin
  if not (csDesigning in ComponentState) then Exit;