whats new ¦  programming tips ¦  indy articles ¦  intraweb articles ¦  informations ¦  links ¦  interviews
 misc ¦  tutorials ¦  Add&Win Game

Tips (1541)

Database (90)
Files (137)
Forms (107)
Graphic (114)
IDE (21)
Indy (5)
Internet / LAN (130)
IntraWeb (0)
Math (76)
Misc (126)
Multimedia (45)
Objects/
ActiveX (51)

OpenTools API (3)
Printing (35)
Strings (83)
System (266)
VCL (242)

Top15

Tips sort by
component


Search Tip

Add new Tip

Add&Win Game

Advertising

29 Visitors Online


 
...draw buttons with rounded corners?
Autor: Alain Gosselin
[ Print tip ]  

Tip Rating (18):  
     




unit RVButton;

interface

uses
  
SysUtils, Classes, Controls, Messages, Graphics, Windows;

const
  
iOffset = 3;

type
  
TRVButton = class(TGraphicControl)
  private
    
FCaption : string;
    FButtonColor: TColor;
    FLButtonDown: boolean;
    FBtnPoints : array[1..2] of TPoint;
    FKRgn : HRgn;
    procedure SetCaption(Value: string);
    procedure SetButtonColor(Value: TColor);
    procedure FreeRegion;
  protected
    procedure 
Paint; override;
    procedure DrawCircle;
    procedure MoveButton;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
  public
    constructor 
Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property 
ButtonColor: TColor read FButtonColor write SetButtonColor;
    property Caption: string read FCaption write SetCaption;
    property Enabled;
    property Font;
    property ParentFont;
    property ParentShowHint;
    property ShowHint;
    property Visible;
    property OnClick;
  end;

procedure Register;

implementation

procedure Register
;
begin
  
RegisterComponents('Samples', [TRVButton]);
end;

{ TRVButton }

constructor TRVButton.Create(AOwner: TComponent);
begin
  inherited 
Create(AOwner);
  ControlStyle := [csClickEvents,csCaptureMouse];
  Width := 50;
  Height := 50;
  FButtonColor := clBtnFace;
  FKRgn := 0;
  FLButtonDown := False;
end;

destructor TRVButton.Destroy;
begin
  if 
FKRgn <> 0 then FreeRegion;
  inherited Destroy;
end;

procedure TRVButton.DrawCircle;
begin
  
FBtnPoints[1] := Point(iOffset,iOffset);
  FBtnPoints[2] := Point(Width - iOffset,Height - iOffset);
  FKRgn := CreateEllipticRgn(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y);
  Canvas.Brush.Color := FButtonColor;
  FillRgn(Canvas.Handle,FKRgn,Canvas.Brush.Handle);
  MoveButton;
end;

procedure TRVButton.FreeRegion;
begin
  if 
FKRgn <> 0 then DeleteObject(FKRgn);
  FKRgn := 0;
end;

procedure TRVButton.MoveButton;
var
  
Color1: TColor;
  Color2: TColor;
begin
  with 
Canvas do
    begin
    if not 
FLButtonDown then
      begin
      
Color1 := clBtnHighlight;
      Color2 := clBtnShadow;
      end
    else
      begin
      
Color1 := clBtnShadow;
      Color2 := clBtnHighLight;
      end;

      Pen.Width := 1;

      if FLButtonDown then Pen.Color := clBlack
      else                 Pen.Color := Color2;

      Ellipse(FBtnPoints[1].x - 2,FBtnPoints[1].y - 2,FBtnPoints[2].x + 2,FBtnPoints[2].y + 2);

      if not FLButtonDown then Pen.Width := 2
      else                     Pen.Width := 1;

      Pen.Color := Color1;

      Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,
          FBtnPoints[2].x,FBtnPoints[1].y,FBtnPoints[1].x,FBtnPoints[2].y);

      Pen.Color := Color2;

      Arc(FBtnPoints[1].x,FBtnPoints[1].y,FBtnPoints[2].x,FBtnPoints[2].y,
          FBtnPoints[1].x,FBtnPoints[2].y,FBtnPoints[2].x,FBtnPoints[1].y);
      end;

  SetCaption('');
end;

procedure TRVButton.Paint;
begin
  inherited 
Paint;
  FreeRegion;
  DrawCircle;
end;

procedure TRVButton.SetButtonColor(Value: TColor);
begin
  if 
Value <> FButtonColor then
    begin
    
FButtonColor := Value;
    Invalidate;
    end;
end;

procedure TRVButton.SetCaption(Value: string);
var
  
X: Integer;
  Y: Integer;
begin
  if 
((Value <> FCaption) and (Value <> '')) then
  begin
    
FCaption := Value;
  end;

  with Canvas.Font do
  begin
    
Name  := Font.Name;
    Size  := Font.Size;
    Style := Font.Style;
    if Self.Enabled then Color := Font.Color
    else
      
Color := clDkGray;
  end;

  X := (Width div 2) - (Canvas.TextWidth(FCaption) div 2);
  Y := (Height div 2) - (Canvas.TextHeight(FCaption) div 2);
  Canvas.TextOut(X, Y, FCaption);
  //  Invalidate;
end;


procedure TRVButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
  if not 
PtInRegion(FKRgn,Message.xPos,Message.yPos) then exit;
  FLButtonDown := True;
  MoveButton;
  inherited;
end;

procedure TRVButton.WMLButtonUp(var Message: TWMLButtonUp);
begin
  if not 
FLButtonDown then exit;
  FLButtonDown := False;
  MoveButton;
  inherited;
end;


end.

 

Rate this tip:

poor
very good


Copyright © by SwissDelphiCenter.ch
All trademarks are the sole property of their respective owners