ddhround.pas

Delphi高级开发指南是开发程序的好帮手

unit DdhRound;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TDdhRoundBtn = class(TButton)
  private
    IsFocused: Boolean;
    FCanvas: TCanvas;
    procedure CNDrawItem(var Msg: TWMDrawItem); message CN_DRAWITEM;
    procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
    procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
      message WM_LBUTTONDBLCLK;
  protected
    procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure SetButtonStyle(ADefault: Boolean); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Color;
    property Width default 100;
    property Height default 50;
    property ParentShowHint;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnEnter;
    property OnExit;
  end;

procedure Register;

implementation

constructor TDdhRoundBtn.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  SetBounds (Left, Top, 100, 50);
  FCanvas := TCanvas.Create;
end;

destructor TDdhRoundBtn.Destroy;
begin
  inherited Destroy;
  FCanvas.Free;
end;

procedure TDdhRoundBtn.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params
    do Style := Style or bs_OwnerDraw;
end;

procedure TDdhRoundBtn.CreateWnd;
var
  hRegion: THandle;
begin
  inherited CreateWnd;
  hRegion := CreateEllipticRgn (0, 0, Width, Height);
  SetWindowRgn (Handle, hRegion, True);
end;

procedure TDdhRoundBtn.SetBounds (ALeft, ATop,
  AWidth, AHeight: Integer);
var
  hRegion: THandle;
begin
  inherited SetBounds (ALeft, ATop, AWidth, AHeight);
  if HandleAllocated then
  begin
    hRegion := CreateEllipticRgn (0, 0, AWidth, AHeight);
    SetWindowRgn (Handle, hRegion, True);
  end;
end;

procedure TDdhRoundBtn.CNDrawItem(var Msg: TWMDrawItem);
var
  OdsDown, OdsFocus, ActionFocus: Boolean;
  Rect: TRect;
begin
  // initialize
  FCanvas.Handle := Msg.DrawItemStruct^.hDC;
  Rect := ClientRect;
  Dec (Rect.Right);
  Dec (Rect.Bottom);
  with Msg.DrawItemStruct^ do
  begin
    OdsDown := itemState and ODS_SELECTED <> 0;
    OdsFocus := itemState and ODS_FOCUS <> 0;
    ActionFocus := ItemAction = oda_Focus
  end;

  with FCanvas do
  begin
    Brush.Color := Color;
    if not ActionFocus then
    begin
      // fill with current color
      Brush.Style := bsSolid;
      FillRect (Rect);
    end;
    // do not fill any more
    Brush.Style := bsClear;
    // draw border if default
    if Default or OdsFocus then
    begin
      Pen.Color := clWindowFrame;
      if not ActionFocus then
        Ellipse (Rect.Left, Rect.Top,
          Rect.Right, Rect.Bottom);
      // reduce the area for further operations
      InflateRect (Rect, -1, -1);
    end;

    if OdsDown then
    begin
      // draw gray border all around
      Pen.Color := clBtnShadow;
      if not ActionFocus then
        Ellipse (Rect.Left, Rect.Top,
          Rect.Right, Rect.Bottom);
    end
    else if not ActionFocus then
    begin
      // gray border (bottom-right)
      Pen.Color :=  clWindowFrame;
      Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse
        Rect.Left, Rect.Bottom, // start
        Rect.Right, Rect.Top); // end
      // white border (top-left)
      Pen.Color :=  clWhite;
      Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse
        Rect.Right, Rect.Top, // start
        Rect.Left, Rect.Bottom); // end
      // gray border (bottom-right, internal)
      Pen.Color := clBtnShadow;
      InflateRect (Rect, -1, -1);
      Arc (Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, // ellipse
        Rect.Left, Rect.Bottom, // start
        Rect.Right, Rect.Top); // end
    end;
    // draw the caption
    InflateRect (Rect, - Width div 5, - Height div 5);
    if OdsDown then
    begin
      Inc (Rect.Left, 2);
      Inc (Rect.Top, 2);
    end;
    Font := Self.Font;
    if not ActionFocus then
      DrawText (FCanvas.Handle, PChar (Caption), -1,
        Rect, dt_SingleLine or dt_Center or dt_VCenter);

    // draw the focus rect around the text
    Brush.Style := bsSolid;
    Pen.Color:= clBlack;
    Brush.Color := clWhite;
    if IsFocused or OdsFocus or ActionFocus then
      DrawFocusRect (Rect);
  end; // with FCanvas and if DrawEntire
  FCanvas.Handle := 0;
  Msg.Result := 1; // message handled
end;

procedure TDdhRoundBtn.CMFontChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TDdhRoundBtn.CMEnabledChanged(var Msg: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TDdhRoundBtn.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;

procedure TDdhRoundBtn.SetButtonStyle (ADefault: Boolean);
begin
  if ADefault <> IsFocused then
  begin
    IsFocused := ADefault;
    Invalidate;
  end;
end;

procedure Register;
begin
  RegisterComponents('DDHB', [TDdhRoundBtn]);
end;

end.