Главная » 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.