unit MenuButton;
interface
uses
SysUtils, Classes, Controls, ExtCtrls, Messages, Graphics, Types;
type
TCenter = (cNone, cVertical, cHorizontal, cBoth);
TBevelStyle = (bNone, bRaised, bLowered, bInsideLowered, bInsideRaised);
TGlyphStyle = (gsLeft, gsTop, gsRight, gsBottom);
TMyBevel =
class(TPersistent)
Private
FStyle,
FHoverStyle,
FClickStyle: TBevelStyle;
FShadow,
FHighlight: TColor;
FWidth: Integer;
Public
Published
property Style: TBevelStyle
read FStyle
write FStyle;
property HoverStyle: TBevelStyle
read FHoverStyle
write FHoverStyle;
property ClickStyle: TBevelStyle
read FClickStyle
write FClickStyle;
property Shadow: TColor
read FShadow
write FShadow;
property Highlight: TColor
read FHighlight
write FHighlight;
property Width: Integer
read FWidth
write FWidth;
end;
TGlyph =
class(TPersistent)
Private
FStyle: TGlyphStyle;
FPicture: TPicture;
Public
constructor Create;
destructor Destroy;
override;
Protected
Published
property Style: TGlyphStyle
read FStyle
write FStyle;
property Picture: TPicture
read FPicture
write FPicture;
end;
TFontCaption =
class(TPersistent)
Private
FFont: TFont;
FText:
String;
Public
constructor Create;
destructor Destroy;
override;
Protected
Published
property Font: TFont
read FFont
write FFont;
property Text:
String read FText
write FText;
end;
TMenuButton =
class(TCustomPanel)
private
FHover,
FClicked,
FAutoSize: Boolean;
FCaption: TFontCaption;
FColor: TColor;
FGlyph: TGlyph;
FCenter: TCenter;
FOnClick,
FOnMouseEnter,
FOnMouseLeave: TNotifyEvent;
FBevel: TMyBevel;
procedure CMMouseEnter(
var Msg: TMessage);
message CM_MOUSEENTER;
procedure CMMouseLeave(
var Msg: TMessage);
message CM_MOUSELEAVE;
procedure SetCaption(Value: TFontCaption);
procedure SetColor(Value: TColor);
procedure SetGlyph(Value: TGlyph);
procedure SetBevel(Value: TMyBevel);
procedure SetCenter(Value: TCenter);
protected
procedure SetAutoSize(Value: Boolean);
override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure Paint;
override;
property Hover: Boolean
read FHover
write FHover;
property Clicked: Boolean
read FClicked
write FClicked;
published
property Bevel: TMyBevel
read FBevel
write SetBevel;
property Center: TCenter
read FCenter
write SetCenter;
property Caption: TFontCaption
read FCaption
write SetCaption;
property Color: TColor
read FColor
write SetColor;
property Glyph: TGlyph
read FGlyph
write SetGlyph;
property OnClick: TNotifyEvent
read FOnClick
write FOnClick;
property OnMouseEnter: TNotifyEvent
read FOnMouseEnter
write FOnMouseEnter;
property OnMouseLeave: TNotifyEvent
read FOnMouseLeave
write FOnMouseLeave;
property AutoSize: Boolean
read FAutoSize
write SetAutoSize;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('
Eigene', [TMenuButton]);
end;
constructor TMenuButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAutoSize := False;
FHover := False;
FClicked := False;
FColor := clBtnFace;;
FBevel := TMyBevel.Create;
FBevel.Highlight := clBtnHighlight;
FBevel.Shadow := clBtnShadow;
FBevel.Style := bLowered;
FBevel.HoverStyle := bRaised;
FBevel.ClickStyle := bLowered;
FBevel.Width := 1;
FGlyph := TGlyph.Create;
FGlyph.FPicture := TPicture.Create;
FCaption := TFontCaption.Create;
FCaption.FFont := TFont.Create;
FCaption.Text := '
MenuButton';
end;
constructor TGlyph.Create;
begin
inherited Create;
FPicture := TPicture.Create;
end;
constructor TFontCaption.Create;
begin
inherited Create;
FFont := TFont.Create;
end;
destructor TMenuButton.Destroy;
begin
FGlyph.FPicture.Free;
FGlyph.Free;
FCaption.FFont.Free;
FCaption.Free;
FBevel.Free;
inherited Destroy;
end;
destructor TGlyph.Destroy;
begin
FPicture.Free;
inherited Destroy;
end;
destructor TFontCaption.Destroy;
begin
FFont.Free;
inherited Destroy;
end;
procedure TMenuButton.Paint;
var
ARect: TRect;
GlyphPos,
TextPos,
TeSize,
GlSize,
AllSize: TPoint;
ActiveBevel: TBevelStyle;
begin
if Assigned(Glyph.Picture.Graphic)
then
begin
GlSize.X := Glyph.Picture.Graphic.Width;
GlSize.Y := Glyph.Picture.Graphic.Height;
case Glyph.Style
of
gsBottom, gsTop: GlSize.Y := GlSize.Y + 1;
gsRight, gsLeft: GlSize.X := GlSize.X + 1;
end;
end
else
begin
GlSize.X := 0;
GlSize.Y := 0;
end;
TeSize.X := Canvas.TextWidth(FCaption.Text);
TeSize.Y := Canvas.TextHeight(FCaption.Text);
if Glyph.Style
in [gsLeft, gsRight]
then
begin
AllSize.X := TeSize.X + GlSize.X + BevelWidth * 2 + 4;
if TeSize.Y < GlSize.Y
then
AllSize.Y := GlSize.Y + BevelWidth * 2 + 4
else
AllSize.Y := TeSize.Y + BevelWidth * 2 + 4;
end
else
begin
if TeSize.X < GlSize.X
then
AllSize.X := GlSize.X + BevelWidth * 2 + 4
else
AllSize.X := TeSize.X + BevelWidth * 2 + 4;
AllSize.Y := GlSize.Y + TeSize.Y + BevelWidth * 2 + 4;
end;
if (AutoSize = True)
then
begin
Width := AllSize.X;
Height := AllSize.Y;
end;
Case Center
of
cHorizontal: Left := Parent.Width
div 2 - Width
div 2;
cVertical: Top := Parent.Height
div 2 - Height
div 2;
cBoth:
begin
Left := Parent.Width
div 2 - Width
div 2;
Top := Parent.Height
div 2 - Height
div 2;
end;
end;
ARect := Rect(0, 0, Width, Height);
Canvas.Brush.Color := Color;
Canvas.Pen.Color := Color;
Canvas.Rectangle(ARect);
if (Clicked = True)
AND (Hover = True)
then
ActiveBevel := Bevel.ClickStyle
else
if Hover = True
then
ActiveBevel := Bevel.HoverStyle
else
ActiveBevel := Bevel.Style;
case Glyph.Style
of
gsLeft:
begin
GlyphPos.X := Width
div 2 - (GlSize.X + TeSize.X)
div 2;
GlyphPos.Y := Height
div 2 - GlSize.Y
div 2;
TextPos.X := GlyphPos.X + GlSize.X;
TextPos.Y := Height
div 2 - TeSize.Y
div 2;
end;
gsRight:
begin
GlyphPos.X := Width
div 2 - (GlSize.X + TeSize.X)
div 2 + TeSize.X + 1;
GlyphPos.Y := Height
div 2 - GlSize.Y
div 2;
TextPos.X := GlyphPos.X - TeSize.X;
TextPos.Y := Height
div 2 - TeSize.Y
div 2;
end;
gsTop:
begin
GlyphPos.X := Width
div 2 - GlSize.X
div 2;
GlyphPos.Y := Height
div 2 - (GlSize.Y + TeSize.Y)
div 2;
TextPos.X := Width
div 2 - TeSize.X
div 2;
TextPos.Y := GlyphPos.Y + GlSize.Y;
end;
gsBottom:
begin
GlyphPos.X := Width
div 2 - GlSize.X
div 2;
GlyphPos.Y := Height
div 2 - (GlSize.Y + TeSize.Y)
div 2 + TeSize.Y + 1;
TextPos.X := Width
div 2 - TeSize.X
div 2;
TextPos.Y := GlyphPos.Y - TeSize.Y;
end;
end;
Canvas.Draw(GlyphPos.X, GlyphPos.Y, Glyph.Picture.Graphic);
Canvas.TextOut(TextPos.X, TextPos.Y, FCaption.Text);
case ActiveBevel
of
bRaised: Frame3D(Canvas, ARect, Bevel.Highlight, Bevel.Shadow, Bevel.Width);
bLowered: Frame3D(Canvas, ARect, Bevel.Shadow, Bevel.Highlight, BevelWidth);
bInsideRaised:
begin
Frame3D(Canvas, ARect, Bevel.Highlight, Bevel.Shadow, Bevel.Width);
Frame3D(Canvas, ARect, Bevel.Shadow, Bevel.Highlight, Bevel.Width);
end;
bInsideLowered:
begin
Frame3D(Canvas, ARect, Bevel.Shadow, Bevel.Highlight, Bevel.Width);
Frame3D(Canvas, ARect, Bevel.Highlight, Bevel.Shadow, Bevel.Width);
end;
end;
end;
procedure TMenuButton.CMMouseEnter(
var Msg: TMessage);
begin
if (csDesigning
in ComponentState) = False
then
begin
Hover := True;
Repaint;
if Assigned(FOnMouseEnter)
then
FOnMouseEnter(self);
end;
end;
procedure TMenuButton.CMMouseLeave(
var Msg: TMessage);
begin
if (csDesigning
in ComponentState) = False
then
begin
Hover := False;
Repaint;
if Assigned(FOnMouseLeave)
then
FOnMouseLeave(self);
end;
end;
procedure TMenuButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
Clicked := False;
Repaint;
end;
procedure TMenuButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
Clicked := True;
Repaint;
if (Assigned(FOnClick))
AND (Hover = True)
then
FOnClick(self);
end;
procedure TMenuButton.SetColor(Value: TColor);
begin
FColor := Value;
Repaint;
end;
procedure TMenuButton.SetGlyph(Value: TGlyph);
begin
FGlyph.Assign(Value);
Repaint;
end;
procedure TMenuButton.SetAutoSize(Value: Boolean);
begin
FAutoSize := Value;
Repaint;
end;
procedure TMenuButton.SetCenter(Value: TCenter);
begin
FCenter := Value;
Repaint;
end;
procedure TMenuButton.SetBevel(Value: TMyBevel);
begin
FBevel := Value;
Repaint;
end;
procedure TMenuButton.SetCaption(Value: TFontCaption);
begin
FCaption := Value;
Canvas.Font := Caption.Font;
Repaint;
end;
end.