Главная » Delphi » Графика » Плоская кнопка

Плоская кнопка

12:11
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.