unit ArgoMenuButton;

interface
uses
 Classes, Graphics, Buttons;

type
 TArgoMenuButton = class(TSpeedButton)
 private
   FStartColor: TColor;
   FEndColor: TColor;
   FUseGradientFill: Boolean;
   procedure SetEndColor(const Value: TColor);
   procedure SetGradientFill(const Value: Boolean);
   procedure SetStartColor(const Value: TColor);
 protected
   procedure Paint; override;
 public
   procedure Assign(Source: TPersistent); override;
 published
   property StartColor: TColor read FStartColor write SetStartColor;
   property EndColor: TColor read FEndColor write SetEndColor;
   property UseGradientFill: Boolean read FUseGradientFill
     write SetGradientFill;
 end;

implementation
uses
 Windows, HSGradient;

{ TArgoMenuButton }

procedure CalcButtonLayout(Canvas: TCanvas; const Client: TRect;
 const Offset: TPoint; const Caption: string; Layout: TButtonLayout; Margin,
 Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect;
 BiDiFlags: LongInt);
var
 TextPos: TPoint;
 ClientSize, GlyphSize, TextSize: TPoint;
 TotalSize: TPoint;
begin
 if (BiDiFlags and DT_RIGHT) = DT_RIGHT then
   if Layout = blGlyphLeft then Layout := blGlyphRight
   else
     if Layout = blGlyphRight then Layout := blGlyphLeft;
 ClientSize := Point(Client.Right - Client.Left, Client.Bottom -
   Client.Top);

 GlyphSize := Point(0, 0);
   
 if Length(Caption) > 0 then
 begin
   TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
   DrawText(Canvas.Handle, PChar(Caption), Length(Caption), TextBounds,
     DT_CALCRECT or BiDiFlags);
   TextSize := Point(TextBounds.Right - TextBounds.Left, TextBounds.Bottom -
     TextBounds.Top);
 end
 else
 begin
   TextBounds := Rect(0, 0, 0, 0);
   TextSize := Point(0,0);
 end;
   
 if Layout in [blGlyphLeft, blGlyphRight] then
 begin
   GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
   TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
 end
 else
 begin
   GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
   TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
 end;
   
 if (TextSize.X = 0) or (GlyphSize.X = 0) then
   Spacing := 0;
   
 if Margin = -1 then
 begin
   if Spacing < 0 then
   begin
     TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
     if Layout in [blGlyphLeft, blGlyphRight] then
       Margin := (ClientSize.X - TotalSize.X) div 3
     else
       Margin := (ClientSize.Y - TotalSize.Y) div 3;
     Spacing := Margin;
   end
   else
   begin
     TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
       Spacing + TextSize.Y);
     if Layout in [blGlyphLeft, blGlyphRight] then
       Margin := (ClientSize.X - TotalSize.X + 1) div 2
     else
       Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
   end;
 end
 else
 begin
   if Spacing < 0 then
   begin
     TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
       (Margin + GlyphSize.Y));
     if Layout in [blGlyphLeft, blGlyphRight] then
       Spacing := (TotalSize.X - TextSize.X) div 2
     else
       Spacing := (TotalSize.Y - TextSize.Y) div 2;
   end;
 end;
   
 case Layout of
   blGlyphLeft:
     begin
       GlyphPos.X := Margin;
       TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
     end;
   blGlyphRight:
     begin
       GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
       TextPos.X := GlyphPos.X - Spacing - TextSize.X;
     end;
   blGlyphTop:
     begin
       GlyphPos.Y := Margin;
       TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
     end;
   blGlyphBottom:
     begin
       GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
       TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
     end;
 end;
   
 with GlyphPos do
 begin
   Inc(X, Client.Left + Offset.X);
   Inc(Y, Client.Top + Offset.Y);
 end;

 OffsetRect(TextBounds, TextPos.X + Client.Left + Offset.X, TextPos.Y + Client.Top + Offset.Y);
end;

procedure DrawButtonText(Canvas: TCanvas; const Caption: string;
 TextBounds: TRect; State: TButtonState; Flags: LongInt);
begin
 with Canvas do
 begin
   Brush.Style := bsClear;
   if State = bsDisabled then
   begin
     OffsetRect(TextBounds, 1, 1);
     Font.Color := clBtnHighlight;
     DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
       DT_CENTER or DT_VCENTER or Flags);
     OffsetRect(TextBounds, -1, -1);
     Font.Color := clBtnShadow;
     DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
       DT_CENTER or DT_VCENTER or Flags);
   end else
     DrawText(Handle, PChar(Caption), Length(Caption), TextBounds,
       DT_CENTER or DT_VCENTER or Flags);
 end;
end;

function DrawButton (Canvas: TCanvas; const Client: TRect;
 const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
 Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean;
 BiDiFlags: LongInt): TRect;
var
 GlyphPos: TPoint;
begin
 CalcButtonLayout(Canvas, Client, Offset, Caption, Layout, Margin, Spacing,
   GlyphPos, Result, BiDiFlags);
 DrawButtonText(Canvas, Caption, Result, State, BiDiFlags);
end;

procedure TArgoMenuButton.Assign(Source: TPersistent);
begin
 if Source is TSpeedButton then
 begin
   BoundsRect := TSpeedButton(Source).BoundsRect;
   Action := TSpeedButton(Source).Action;
   Flat := TSpeedButton(Source).Flat;
   Transparent := TSpeedButton(Source).Transparent;
   Font := TSpeedButton(Source).Font;
   AllowAllUp := TSpeedButton(Source).AllowAllUp;
 end else
   inherited;
end;

procedure TArgoMenuButton.Paint;
var
 PaintRect: TRect;
 GradientFill: THSGradientFill;
begin
 if (csDesigning in ComponentState) or not
    (Fstate in [bsDown,bsExclusive]) then
   inherited
 else begin
   Canvas.Font := Self.Font;
   Canvas.Font.Color := clYellow;
   Canvas.Brush.Color := $00804000;
   PaintRect := Rect(0, 0, Width, Height);
   if UseGradientFill then
   begin
     GradientFill := THSGradientFill.Create;
     try
       GradientFill.Style := gsVertical;
       GradientFill.StartColor := FStartColor;
       GradientFill.EndColor := FEndColor;
       GradientFill.FillRect(Canvas, PaintRect);
     finally
       GradientFill.Free;
     end;
   end
   else
     Canvas.FillRect(PaintRect);
   DrawButton (Canvas, PaintRect, Point(0,0), Caption, Layout, Margin, Spacing,
     FState, Transparent, DrawTextBiDiModeFlags(0));
 end;
end;

procedure TArgoMenuButton.SetEndColor(const Value: TColor);
begin
 if FEndColor <> Value then
 begin
   FEndColor := Value;
   Invalidate;
 end;
end;

procedure TArgoMenuButton.SetGradientFill(const Value: Boolean);
begin
 if FUseGradientFill <> Value then
 begin
   FUseGradientFill := Value;
   Invalidate;
 end;
end;

procedure TArgoMenuButton.SetStartColor(const Value: TColor);
begin
 if FStartColor <> Value then
 begin
   FStartColor := Value;
   Invalidate;
 end;
end;

end.

An access method for a property with an index specifier must take an extra value parameter of type Integer. For a read function, it must be the last parameter; for a write procedure, it must be the second-to-last parameter (preceding the parameter that specifies the property value). When a program accesses the property, the property&#146;s integer constant is automatically passed to the access method.

unit KMultiImageButton;

interface

uses
 SysUtils, Classes, Controls, Buttons, Graphics, Types, Messages;

type
 TMultiImageButtonStates = (mibsNormal, mibsDown, mibsHover, mibsDisabled);

 TKMultiImageButton = class(TGraphicControl)
 private
   FImages: array [TMultiImageButtonStates] of TPicture;
   FButtonState: TMultiImageButtonStates;
   { Private declarations }
 protected
   { Protected declarations }
   function GetImage(const Index: TMultiImageButtonStates): TPicture;
   procedure SetImage(const Index: TMultiImageButtonStates; const Value: TPicture);
   procedure SetButtonState(const AState: TMultiImageButtonStates);

   procedure Paint; override;
   procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
   procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
   procedure MouseDown(Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer); override;
   procedure MouseUp(Button: TMouseButton;
    Shift: TShiftState; X, Y: Integer); override;  
 public
   { Public declarations }
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   { Published declarations }
   property Caption;
   property Action;

   property ImageNormal: TPicture index mibsNormal read GetImage write SetImage;
   property ImageDisabled: TPicture index mibsDisabled read GetImage write SetImage;
   property ImageDown: TPicture index mibsDown read GetImage write SetImage;
   property ImageHover: TPicture index mibsHover read GetImage write SetImage;

   property OnClick;
   property OnDblClick;
   property OnMouseDown;
   property OnMouseEnter;
   property OnMouseLeave;
   property OnMouseMove;
   property OnMouseUp;
   property OnMouseWheel;
   property OnMouseWheelDown;
   property OnMouseWheelUp;

 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents('KSoftWare', [TKMultiImageButton]);
end;

{ TKMultiImageButton }

procedure TKMultiImageButton.CMMouseEnter(var Message: TMessage);
begin
 SetButtonState(mibsHover);
end;

procedure TKMultiImageButton.CMMouseLeave(var Message: TMessage);
begin
 SetButtonState(mibsNormal);
end;

constructor TKMultiImageButton.Create(AOwner: TComponent);
var
 I: TMultiImageButtonStates;
begin
 inherited;
 for I := Low(TMultiImageButtonStates) to High(TMultiImageButtonStates) do
   FImages[I] := TPicture.Create;
end;

destructor TKMultiImageButton.Destroy;
var
 I: TMultiImageButtonStates;
begin
 for I := Low(TMultiImageButtonStates) to High(TMultiImageButtonStates) do
   FImages[I].Free;
 inherited;
end;

function TKMultiImageButton.GetImage(const Index: TMultiImageButtonStates): TPicture;
begin
 Result := FImages[Index];
end;

procedure TKMultiImageButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
 X, Y: Integer);
begin
 inherited;
 SetButtonState(mibsDown);
end;

procedure TKMultiImageButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
 X, Y: Integer);
begin
 inherited;
 SetButtonState(mibsNormal);
end;

procedure TKMultiImageButton.Paint;
begin
 if csDesigning in ComponentState then
   with Canvas do
   begin
     Pen.Style := psDash;
     Brush.Style := bsClear;
     Rectangle(0, 0, Width, Height);
   end;

 Canvas.Font := Self.Font;
 with GetImage(FButtonState) do
   Canvas.StretchDraw(ClientRect, Graphic);
 Canvas.TextOut(0, 0, Caption);
end;

procedure TKMultiImageButton.SetButtonState(
 const AState: TMultiImageButtonStates);
begin
 if not Enabled then
 begin
   FButtonState := mibsDisabled;
   Exit;
 end
 else
   if FButtonState <> AState then
     FButtonState := AState;
 Invalidate;    
end;

procedure TKMultiImageButton.SetImage(const Index: TMultiImageButtonStates;
 const Value: TPicture);
begin
 FImages[Index].Assign(Value);
 if FButtonState = Index then
  Invalidate;
end;

end.

procedure TKMultiImageButton.CMEnabledChanged(var Message: TMessage);
begin
 if Enabled then
   SetButtonState(mibsNormal)
 else
   SetButtonState(mibsDisabled);
 inherited;
end;

procedure TKMultiImageButton.CMEnabledChanged(var Message: TMessage);
const AState: array[boolean] of TMultiImageButtonStates = (mibsDisabled,mibsNormal);
begin
 inherited;
SetButtonState(AState[Enabled]);
end;

procedure TKMultiImageButton.SetButtonState(AState: TMultiImageButtonStates);
var P: TPoint;
begin
if not Enabled then AState := mibsDisabled;
if fButtonState = AState then Exit;
if FButtonState = mibsDisabled then begin
 GetCursorPos(P);
 P := ScrennToClient(P);
 if PtInRect(P,ClientRect) then
   if csLButtonDown in ControlState
     then AState := mibsDown
     else AState := mibsHover
   else AState := mibsNormal;
FButtonState := AState;
Invalidate;    
end;

(mibsNormal, mibsDown, mibsHover, mibsDisabled);

SetButtonState

ControlMiddle.X := Width div 2;
 ControlMiddle.Y := Height div 2;

 TextMiddle.X := Canvas.TextWidth(Caption) div 2;
 TextMiddle.Y := Canvas.TextHeight(Caption) div 2;

 Canvas.Brush.Style := bsClear;
 Canvas.TextOut(ControlMiddle.X &#151; TextMiddle.X, ControlMiddle.Y &#151; TextMiddle.Y, Caption);