K210.ORG

unit esFlatButton;

 

interface

 

uses

  Windows, Messages, SysUtils, Classes, Controls, Graphics, Buttons,

  ExtCtrls,GraphUtil;

type

  TTextPos = (tpBottom, tpRight);

type

  TesFlatButton = class(TCustomControl)

  private

    FOnMouseEnter: TNotifyEvent;

    FOnMouseLeave: TNotifyEvent;

    FColor, FColorHL, FColorBorder, FColorBorderPressed, FColorPressed: TColor;

    FDown: Boolean;

    FGroupIndex: Integer;

    FUrl: string;

    FBuffer: TBitmap;

    FBitmap: TBitmap;

    FPicture: TPicture;

    FDrawing:Boolean;

    FTextPos: TTextPos;

    FMoveGif: boolean;

    procedure UpdateExclusive;

    procedure WMSize(var Message: TWMSize); message WM_SIZE;

    procedure WMMove(var Message: TWMMove); message WM_MOVE;

    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;

    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;

    procedure CMButtonPressed(var Message: TMessage); message CM_BUTTONPRESSED;

    procedure SetColors(const Index: Integer; const Value: TColor);

    procedure PictureChanged(Sender: TObject);

    procedure SetGroupIndex(const Value: Integer);

    procedure SetDown(Value: Boolean);

 

    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;

    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;

    procedure SetTextPos(const Value: TTextPos);

    procedure SetPicture(const Value: TPicture);

    { Private declarations }

  protected

    FState: TButtonState;

    MouseInControl: boolean;

    procedure Paint; override;

    procedure PaintButton;

    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

    { Protected declarations }

  public

    constructor Create(AOwner: TComponent); override;

    destructor Destroy; override;

    procedure SetColorsFromBase(clr:TColor;darked:integer);

    { Public declarations }

  published

  property Action;

  property Align;

    property Anchors;

    property Caption;

    property Font;

    property Hint;

    property ShowHint;

    property Enabled;

    property Visible;

    property Url: string read FUrl write FUrl;

    property TextPos: TTextPos read FTextPos write SetTextPos;

    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;

    property Down: Boolean read FDown write SetDown default false;

    property Color: TColor index 4 read FColor write SetColors default $00E1E1E1;

    property ColorHL: TColor index 0 read FColorHL write SetColors default $007DBEFF;

    property ColorBorder: TColor index 1 read FColorBorder write SetColors default $007E7E7E;

    property ColorBorderPressed: TColor index 2 read FColorBorderPressed write SetColors default $000000B9;

    property ColorPressed: TColor index 3 read FColorPressed write SetColors default $000000B9;

    property Picture: TPicture read FPicture write SetPicture;

    property MoveGif: boolean read FMoveGif write FMoveGif;

    property OnMouseDown;

    property OnMouseMove;

    property OnMouseUp;

    property OnClick;

    procedure Click; override;

    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;

    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;

    { Published declarations }

  end;

 

procedure Register;

 

implementation

 

procedure Register;

begin

  RegisterComponents('esVCL', [TesFlatButton]);

end;

 

procedure TesFlatButton.Click;

begin

  inherited Click;

  self.SetDown(true);

end;

 

procedure TesFlatButton.CMButtonPressed(var Message: TMessage);

var

  Sender: TesFlatButton;

begin

  if Message.WParam = FGroupIndex then

  begin

    Sender := TesFlatButton(Message.LParam);

    if Sender <> Self then

    begin

      if Sender.Down and FDown then

      begin

        FDown := False;

        FState := bsUp;

        Invalidate;

      end;

    end;

  end;

 

end;

 

procedure TesFlatButton.CMFontChanged(var Message: TMessage);

begin

  Invalidate;

end;

 

procedure TesFlatButton.CMMouseEnter(var Message: TMessage);

begin

  inherited;

  if Assigned(FOnMouseEnter) then

    FOnMouseEnter(Self);

  MouseInControl := true;

  Invalidate;

end;

 

procedure TesFlatButton.CMMouseLeave(var Message: TMessage);

begin

  inherited;

  if Assigned(FOnMouseLeave) then

    FOnMouseLeave(Self);

  MouseInControl := false;

  Invalidate;

end;

 

procedure TesFlatButton.CMTextChanged(var Message: TMessage);

begin

  Invalidate;

end;

 

constructor TesFlatButton.Create(AOwner: TComponent);

begin

  inherited;

  FColorHL := $007DBEFF;

  FColorBorder := $007E7E7E;

  FColorBorderPressed := $000000B9;

  FColorPressed := $000000B9;

  Color := $00E1E1E1;

  FBuffer := TBitmap.Create;

   FPicture := TPicture.Create;

  FPicture.OnChange := PictureChanged;

  self.DoubleBuffered := true;

end;

 

destructor TesFlatButton.Destroy;

begin

  if assigned(FBitmap) then FBitmap.Free;

  FBuffer.Free;

  FPicture.Free;

  inherited;

end;

 

procedure TesFlatButton.MouseDown(Button: TMouseButton; Shift: TShiftState;

  X, Y: Integer);

begin

  inherited MouseDown(Button, Shift, X, Y);

  if (Button = mbLeft) and Enabled then

  begin

    if not FDown then

    begin

      FState := bsDown;

      Invalidate;

    end;

  end;

end;

 

 

procedure TesFlatButton.MouseUp(Button: TMouseButton; Shift: TShiftState;

  X, Y: Integer);

begin

  inherited MouseUp(Button, Shift, X, Y);

  if FGroupIndex = 0 then

  begin

    FState := bsUp;

  end

  else

  begin

    SetDown(not FDown);

  end;

  Invalidate;

end;

 

procedure TesFlatButton.Paint;

begin

  PaintButton;

end;

 

procedure TesFlatButton.SetColors(const Index: Integer;

  const Value: TColor);

begin

  case Index of

    0: FColorHL := Value;

    1: FColorBorder := Value;

    2: FColorBorderPressed := Value;

    3: FColorPressed := Value;

    4: begin

        FColor := Value;

      end;

  end;

  Invalidate;

end;

 

procedure TesFlatButton.SetGroupIndex(const Value: Integer);

begin

  if FGroupIndex <> Value then

  begin

    FGroupIndex := Value;

    UpdateExclusive;

  end;

end;

 

procedure TesFlatButton.SetDown(Value: Boolean);

begin

  if FGroupIndex = 0 then Value := False;

  if FDown then begin

    Exit;

  end;

  FDown := Value;

  if Value then

  begin

    FState := bsDown;

  end

  else

  begin

    FState := bsUp;

  end;

 

  Invalidate;

  if Value then UpdateExclusive;

end;

 

 

procedure TesFlatButton.UpdateExclusive;

var

  Msg: TMessage;

begin

  if (FGroupIndex <> 0) and (Parent <> nil) then

  begin

    Msg.Msg := CM_BUTTONPRESSED;

    Msg.WParam := FGroupIndex;

    Msg.LParam := Longint(Self);

    Msg.Result := 0;

    Parent.Broadcast(Msg);

  end;

 

end;

 

procedure TesFlatButton.WMMove(var Message: TWMMove);

begin

  inherited;

  Invalidate;

end;

 

procedure TesFlatButton.WMSize(var Message: TWMSize);

begin

  inherited;

  Invalidate;

end;

 

procedure TesFlatButton.PaintButton;

var

  r, textr: tRect;

  lLeft, lTop,picHeight,picWidth: integer;

  Save: Boolean;

begin

  r := ClientRect;

  //inherited;

    Save := FDrawing;

  FDrawing := True;

  try

  if MouseInControl then begin

    canvas.brush.color := FColorHL;

  end

  else begin

    if FDown then

      canvas.brush.color := FColorPressed else

      canvas.brush.color := FColor;

  end;

  canvas.FillRect(r);

  Canvas.Brush.Style := bsclear;

  if FDown then begin

    canvas.Pen.Color := FColorBorderPressed;

  end

  else begin

    canvas.Pen.Color := FColorBorder;

  end;

  canvas.Rectangle(r);

 

 

  InflateRect(r, -1, -1);

 

  if FPicture.Graphic<>nil then begin

  picHeight:=FPicture.Graphic.Height;

  picWidth:=FPicture.Graphic.Width;

  end else

 

  begin

  picHeight:=0;

  picWidth:=0;

  end;

  case FTextPos of

    tpBottom: begin

        lLeft := width div 2 - picWidth div 2;

        lTop := height div 2 - (canvas.TextHeight(caption) div 2 + picHeight div 2);

        textr := Rect(0, lTop + picWidth, r.Right, lTop + picWidth + canvas.TextHeight(caption));

      end;

    tpRight: begin

        lLeft := width div 2 - (picWidth div 2 + canvas.TextWidth(' ' + caption) div 2);

        lTop := height div 2 - picHeight div 2;

        textr := Rect(lLeft + picHeight, 0, lLeft + picHeight + canvas.TextWidth(' ' + caption), r.Bottom);

      end;

  end;

 

 

  if (FState = bsDown) and (not FDown) then begin

    Frame3D(canvas, r, clBlack, clwhite, 1);

    OffsetRect(textr, 1, 1);

    if FMoveGif then begin

      lLeft := lLeft + 1;

      lTop := lTop + 1;

    end;

  end;

  if FPicture.Graphic<>nil then

  canvas.Draw(lLeft, lTop, FPicture.Graphic);

  Canvas.Font := Font;

  Canvas.Font.Color:=Font.Color;

  DrawText(Canvas.Handle, PChar(Caption), Length(Caption), textr, DT_CENTER or DT_VCENTER or DT_WORDBREAK or DT_NOCLIP);

  finally

      FDrawing := Save;

  end;

  end;

 

procedure TesFlatButton.SetTextPos(const Value: TTextPos);

begin

  FTextPos := Value;

  Invalidate;

end;

 

function ColorAdjustLuma2(clrRGB: TColorRef;toLuma:integer): TColorRef;

var

  H, L, S: Word;

begin

  ColorRGBToHLS(ColorToRGB(clrRGB), H, L, S);

  Result := TColor(ColorHLSToRGB(H, toLuma, S));

end;

 

procedure TesFlatButton.SetColorsFromBase(clr: TColor; darked:integer);

begin

   Color:=ColorAdjustLuma2(clr,225+darked);

   FColorBorder:=ColorAdjustLuma2(clr,50);

   FColorBorderPressed:=ColorAdjustLuma2(clr,50);

   Font.Color:=ColorBorder;

   FColorPressed:=ColorAdjustLuma2(clr,205+darked);

   Invalidate;

end;

 

procedure TesFlatButton.PictureChanged(Sender: TObject);

begin

if  FDrawing then Update else Invalidate;

end;

 

procedure TesFlatButton.SetPicture(const Value: TPicture);

begin

  FPicture.Assign(Value);

end;

 

end.