DELPHI/Часто задаваемые вопросы и ответы на них/Компоненты



На главную

Подписка

Новости

Главная / DELPHI / Часто задаваемые вопросы и ответы на них / Компоненты / Круглая кнопка, кнопка с изменяющимися размерами

Круглая кнопка, кнопка с изменяющимися размерами

DDHAPPX_PAS.HTM

unit DdhAppX;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, ShellApi, Menus;

type
  TDdhAppExt = class(TComponent)
  private
    // design time clone or runtime Application
    CurrApp: TApplication;
    // window procedures
    OldWndProc, NewWndProc: Pointer;
    // tray support
    fTrayIconActive: Boolean;
    fTrayIcon: TIcon;
    fTrayPopup: TPopupMenu;
    nid: TNotifyIconData;
    fOnTrayDefault: TNotifyEvent;
    procedure IconTrayWndProc (var Msg: TMessage);
  protected
    // property and event access methods
    function GetIcon: TIcon;
    procedure SetIcon (Value: TIcon);
    function GetTitle: string;
    procedure SetTitle(Value: string);
    function GetHelpFile: string;
    procedure SetHelpFile(Value: string);
    function GetHintColor: TColor;
    procedure SetHintColor(Value: TColor);
    function GetHintPause: Integer;
    procedure SetHintPause(Value: Integer);
    function GetHintShortPause: Integer;
    procedure SetHintShortPause(Value: Integer);
    function GetHintHidePause: Integer;
    procedure SetHintHidePause(Value: Integer);
    function GetShowHint: Boolean;
    procedure SetShowHint(Value: Boolean);
    function GetOnActivate: TNotifyEvent;
    procedure SetOnActivate(Value: TNotifyEvent);
    function GetOnDeactivate: TNotifyEvent;
    procedure SetOnDeactivate(Value: TNotifyEvent);
    function GetOnException: TExceptionEvent;
    procedure SetOnException(Value: TExceptionEvent);
    function GetOnIdle: TIdleEvent;
    procedure SetOnIdle(Value: TIdleEvent);
    function GetOnHelp: THelpEvent;
    procedure SetOnHelp(Value: THelpEvent);
    function GetOnHint: TNotifyEvent;
    procedure SetOnHint(Value: TNotifyEvent);
    function GetOnMessage: TMessageEvent;
    procedure SetOnMessage(Value: TMessageEvent);
    function GetOnMinimize: TNotifyEvent;
    procedure SetOnMinimize(Value: TNotifyEvent);
    function GetOnRestore: TNotifyEvent;
    procedure SetOnRestore(Value: TNotifyEvent);
    function GetOnShowHint: TShowHintEvent;
    procedure SetOnShowHint(Value: TShowHintEvent);
    procedure SetTrayIconActive (Value: Boolean);
    procedure SetTrayIcon (Value: TIcon);
    procedure IconChange (Sender: TObject);
    procedure SetTrayHint (Value: string);
    function GetTrayHint: string;
    procedure SetTrayPopup (Value: TPopupMenu);
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    // TApplication properties
    property Icon: TIcon
      read GetIcon  write SetIcon ;
    property Title: string
      read GetTitle write SetTitle;
    property HelpFile: string
      read GetHelpFile write SetHelpFile;
    property HintColor: TColor
      read GetHintColor write SetHintColor default clInfoBk;
    property HintPause: Integer
      read GetHintPause write SetHintPause default 500;
    property HintShortPause: Integer
      read GetHintShortPause write SetHintShortPause default 50;
    property HintHidePause: Integer
      read GetHintHidePause write SetHintHidePause default 2500;
    property ShowHint: Boolean
      read GetShowHint write SetShowHint default False;
    // tray icon properties
    property TrayIconActive: Boolean
      read fTrayIconActive write SetTrayIconActive default False;
    property TrayIcon: TIcon
      read fTrayIcon write SetTrayIcon;
    property TrayHint: string
      read GetTrayHint write SetTrayHint;
    property TrayPopup: TPopupMenu
      read fTrayPopup write SetTrayPopup;
    property OnTrayDefault: TNotifyEvent
      read fOnTrayDefault write fOnTrayDefault;
    // TApplication events
    property OnActivate: TNotifyEvent
      read GetOnActivate write SetOnActivate;
    property OnDeactivate: TNotifyEvent
      read GetOnDeactivate write SetOnDeactivate;
    property OnException: TExceptionEvent
      read GetOnException write SetOnException;
    property OnIdle: TIdleEvent
      read GetOnIdle write SetOnIdle;
    property OnHelp: THelpEvent
      read GetOnHelp write SetOnHelp;
    property OnHint: TNotifyEvent
      read GetOnHint write SetOnHint;
    property OnMessage: TMessageEvent
      read GetOnMessage write SetOnMessage;
    property OnMinimize: TNotifyEvent
      read GetOnMinimize write SetOnMinimize;
    property OnRestore: TNotifyEvent
      read GetOnRestore write SetOnRestore;
    property OnShowHint: TShowHintEvent
      read GetOnShowHint write SetOnShowHint;
  end;

procedure Register;

implementation

const
  wm_IconMessage = wm_User;

var
  AppCompCounter: Integer;

constructor TDdhAppExt.Create(AOwner: TComponent);
begin
  // check if already created
  Inc (AppCompCounter);
  if AppCompCounter > 1 then
    raise Exception.Create (
      'Duplicated DdhAppExt component');
  inherited Create(AOwner);

  // application object initialization
  if csDesigning in ComponentState then
  begin
    CurrApp := TApplication.Create (nil);
    CurrApp.Icon := nil;
    CurrApp.Title := '';
    CurrApp.HelpFile := '';
  end
  else
    CurrApp := Application;

  // tray icon initialization
  fTrayIconActive := False;
  fTrayIcon := TIcon.Create;
  fTrayIcon.OnChange := IconChange;

  nid.cbSize := sizeof (nid);
  nid.wnd := CurrApp.Handle;
  nid.uID := 1; // icon ID
  nid.uCallBackMessage := wm_IconMessage;
  nid.hIcon := CurrApp.Icon.Handle;
  StrLCopy (nid.szTip, PChar('Tip'), 64);
  nid.uFlags := nif_Message or
    nif_Icon or nif_Tip;

  // subclass the application
  if not (csDesigning in ComponentState) then
  begin
    NewWndProc := MakeObjectInstance (IconTrayWndProc);
    OldWndProc := Pointer (SetWindowLong (
      CurrApp.Handle, gwl_WndProc, Longint (NewWndProc)));
  end
  else
  begin
    // default values
    NewWndProc := nil;
    OldWndPRoc := nil;
  end;
end;

destructor TDdhAppExt.Destroy;
begin
  // remove the application window procedure
  if csDesigning in ComponentState then
  begin
    // re-install the original window procedure
    SetWindowLong (CurrApp.Handle, gwl_WndProc,
      Longint (OldWndProc));
    // free the object instance
    if Assigned (NewWndProc) then
      FreeObjectInstance (NewWndProc);
  end;
  Dec (AppCompCounter);
  // remove the tray icon
  if fTrayIconActive then
    Shell_NotifyIcon (NIM_DELETE, @nid);
  fTrayIcon.Free;
  // default destructor
  inherited Destroy;
end;

procedure TDdhAppExt.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification (AComponent, Operation);
  if (Operation = opRemove) and (AComponent = fTrayPopup) then
    fTrayPopup := nil;
end;

// property access methods

function TDdhAppExt.GetIcon : TIcon;
begin
  Result := CurrApp.Icon ;
end;

procedure TDdhAppExt.SetIcon (Value: TIcon);
begin
  CurrApp.Icon := Value;
end;

function TDdhAppExt.GetTitle: string;
begin
  Result := CurrApp.Title;
end;

procedure TDdhAppExt.SetTitle(Value: string);
begin
  CurrApp.Title := Value;
end;

function TDdhAppExt.GetHelpFile: string;
begin
  Result := CurrApp.HelpFile;
end;

procedure TDdhAppExt.SetHelpFile(Value: string);
begin
  CurrApp.HelpFile := Value;
end;

function TDdhAppExt.GetHintColor: TColor;
begin
  Result := CurrApp.HintColor;
end;

procedure TDdhAppExt.SetHintColor(Value: TColor);
begin
  CurrApp.HintColor := Value;
end;

function TDdhAppExt.GetHintPause: Integer;
begin
  Result := CurrApp.HintPause;
end;

procedure TDdhAppExt.SetHintPause(Value: Integer);
begin
  CurrApp.HintPause := Value;
end;

function TDdhAppExt.GetHintShortPause: Integer;
begin
  Result := CurrApp.HintShortPause;
end;

procedure TDdhAppExt.SetHintShortPause(Value: Integer);
begin
  CurrApp.HintShortPause := Value;
end;

function TDdhAppExt.GetHintHidePause: Integer;
begin
  Result := CurrApp.HintHidePause;
end;

procedure TDdhAppExt.SetHintHidePause(Value: Integer);
begin
  CurrApp.HintHidePause := Value;
end;

function TDdhAppExt.GetShowHint: Boolean;
begin
  Result := CurrApp.ShowHint;
end;

procedure TDdhAppExt.SetShowHint(Value: Boolean);
begin
  CurrApp.ShowHint := Value;
end;

function TDdhAppExt.GetOnActivate: TNotifyEvent;
begin
  Result := CurrApp.OnActivate;
end;

procedure TDdhAppExt.SetOnActivate(Value: TNotifyEvent);
begin
  CurrApp.OnActivate := Value;
end;

function TDdhAppExt.GetOnDeactivate: TNotifyEvent;
begin
  Result := CurrApp.OnDeactivate;
end;

procedure TDdhAppExt.SetOnDeactivate(Value: TNotifyEvent);
begin
  CurrApp.OnDeactivate := Value;
end;

function TDdhAppExt.GetOnException: TExceptionEvent;
begin
  Result := CurrApp.OnException;
end;

procedure TDdhAppExt.SetOnException(Value: TExceptionEvent);
begin
  CurrApp.OnException := Value;
end;

function TDdhAppExt.GetOnIdle: TIdleEvent;
begin
  Result := CurrApp.OnIdle;
end;

procedure TDdhAppExt.SetOnIdle(Value: TIdleEvent);
begin
  CurrApp.OnIdle := Value;
end;

function TDdhAppExt.GetOnHelp: THelpEvent;
begin
  Result := CurrApp.OnHelp;
end;

procedure TDdhAppExt.SetOnHelp(Value: THelpEvent);
begin
  CurrApp.OnHelp := Value;
end;

function TDdhAppExt.GetOnHint: TNotifyEvent;
begin
  Result := CurrApp.OnHint;
end;

procedure TDdhAppExt.SetOnHint(Value: TNotifyEvent);
begin
  CurrApp.OnHint := Value;
end;

function TDdhAppExt.GetOnMessage: TMessageEvent;
begin
  Result := CurrApp.OnMessage;
end;

procedure TDdhAppExt.SetOnMessage(Value: TMessageEvent);
begin
  CurrApp.OnMessage := Value;
end;

function TDdhAppExt.GetOnMinimize: TNotifyEvent;
begin
  Result := CurrApp.OnMinimize;
end;

procedure TDdhAppExt.SetOnMinimize(Value: TNotifyEvent);
begin
  CurrApp.OnMinimize := Value;
end;

function TDdhAppExt.GetOnRestore: TNotifyEvent;
begin
  Result := CurrApp.OnRestore;
end;

procedure TDdhAppExt.SetOnRestore(Value: TNotifyEvent);
begin
  CurrApp.OnRestore := Value;
end;

function TDdhAppExt.GetOnShowHint: TShowHintEvent;
begin
  Result := CurrApp.OnShowHint;
end;

procedure TDdhAppExt.SetOnShowHint(Value: TShowHintEvent);
begin
  CurrApp.OnShowHint := Value;
end;

// tray icon support

procedure TDdhAppExt.SetTrayIconActive (Value: Boolean);
begin
  if Value <> fTrayIconActive then
  begin
    fTrayIconActive := Value;
    if not (csDesigning in ComponentState) then
    begin
      if fTrayIconActive then
        Shell_NotifyIcon (NIM_ADD, @nid)
      else
        Shell_NotifyIcon (NIM_DELETE, @nid);
    end;
  end;
end;

procedure TDdhAppExt.SetTrayIcon (Value: TIcon);
begin
  fTrayIcon.Assign (Value);
end;

procedure TDdhAppExt.IconChange (Sender: TObject);
begin
  if not (fTrayIcon.Empty) then
    nid.hIcon := fTrayIcon.Handle
  else
    nid.hIcon := CurrApp.MainForm.Icon.Handle;
  if fTrayIconActive and
      not (csDesigning in ComponentState) then
    Shell_NotifyIcon (NIM_MODIFY, @nid);
end;

function TDdhAppExt.GetTrayHint: string;
begin
  Result := string (nid.szTip);
end;

procedure TDdhAppExt.SetTrayHint (Value: string);
begin
  StrLCopy (nid.szTip, PChar(Value), 64);
  if fTrayIconActive and
      not (csDesigning in ComponentState) then
    Shell_NotifyIcon (NIM_MODIFY, @nid);
end;

procedure TDdhAppExt.SetTrayPopup (Value: TPopupMenu);
begin
  if Value <> fTrayPopup then
  begin
    fTrayPopup := Value;
    if Assigned (fTrayPopup) then
      fTrayPopup.FreeNotification (self);
  end;
end;

procedure TDdhAppExt.IconTrayWndProc (var Msg: TMessage);
var
  Pt: TPoint;
begin
  // show the popup menu
  if (Msg.Msg = wm_IconMessage) and
    (Msg.lParam = wm_rButtonDown) and
    Assigned (fTrayPopup) then
  begin
    SetForegroundWindow (CurrApp.MainForm.Handle);
    GetCursorPos (Pt);
    fTrayPopup.Popup (Pt.x, Pt.y);
  end
  // do the default action
  else if (Msg.Msg = wm_IconMessage) and
    (Msg.lParam = wm_lButtonDblClk) and
    Assigned (fOnTrayDefault) then
  begin
    SetForegroundWindow (CurrApp.MainForm.Handle);
    fOnTrayDefault (self);
  end
  else
    // original window procedure
    Msg.Result := CallWindowProc (OldWndProc,
      CurrApp.Handle, Msg.Msg, Msg.WParam, Msg.LParam);
end;

// component registration

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

initialization
  AppCompCounter := 0;
end.

DDHFORMX_PAS.HTM

unit DdhFormX;

interface

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

type
  TDdhFormExt = class(TComponent)
  private
    // window procedures
    OldWndProc, NewWndProc: Pointer;
    // MinMaxInfo data
    fMaximizedWidth: Integer;
    fMaximizedHeight: Integer;
    fMaximizedPosX: Integer;
    fMaximizedPosY: Integer;
    fMinimumTrackWidth: Integer;
    fMinimumTrackHeight: Integer;
    fMaximumTrackWidth: Integer;
    fMaximumTrackHeight: Integer;
    // background bitmap
    fBackBitmap: TBitmap;
    procedure SetBackBitmap (Value: TBitmap);
  protected
    function FormHandle: THandle;
    procedure NewWndMethod (var Msg: TMessage);
    procedure BackBitmapChanged (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BackBitmap: TBitmap
      read fBackBitmap write SetBackBitmap;
    property MaximizedWidth: Integer
      read fMaximizedWidth write fMaximizedWidth
      default 0;
    property MaximizedHeight: Integer
      read fMaximizedHeight write fMaximizedHeight
      default 0;
    property MaximizedPosX: Integer
      read fMaximizedPosX write fMaximizedPosX
      default 0;
    property MaximizedPosY: Integer
      read fMaximizedPosY write fMaximizedPosY
      default 0;
    property MinimumTrackWidth: Integer
      read fMinimumTrackWidth write fMinimumTrackWidth
      default 0;
    property MinimumTrackHeight: Integer
      read fMinimumTrackHeight write fMinimumTrackHeight
      default 0;
    property MaximumTrackWidth: Integer
      read fMaximumTrackWidth write fMaximumTrackWidth
      default 0;
    property MaximumTrackHeight: Integer
      read fMaximumTrackHeight write fMaximumTrackHeight
      default 0;
  end;

procedure Register;

implementation

constructor TDdhFormExt.Create (AOwner: TComponent);
var
  I: Integer;
begin
  // check if the owner is a form
  if (Owner = nil) or not (AOwner is TForm) then
    raise Exception.Create (
      'Owner of DdhFormExt component must be a form');
  // create a single instance only
  for I := 0 to AOwner.ComponentCount - 1 do
    if AOwner.Components[I] is TDdhFormExt then
      raise Exception.Create (
        'DdhFormExt component duplicated in ' +
        AOwner.Name);
  // default creation
  inherited Create (AOwner);
  // form subclassing (runtime only)
  if not (csDesigning in ComponentState) then
  begin
    NewWndProc := MakeObjectInstance (NewWndMethod);
    OldWndProc := Pointer (SetWindowLong (
      FormHandle, gwl_WndProc, Longint (NewWndProc)));
  end
  else
  begin
    // default values
    NewWndProc := nil;
    OldWndPRoc := nil;
  end;
  fBackBitmap := TBitmap.Create;
  fBackBitmap.OnChange := BackBitmapChanged;
end;

destructor TDdhFormExt.Destroy;
begin
  if Assigned (NewWndProc) then
  begin
    FreeObjectInstance (NewWndProc);
    SetWindowLong (FormHandle, gwl_WndProc,
      Longint (OldWndProc));
  end;
  fBackBitmap.Free;
  inherited Destroy;
end;

function TDdhFormExt.FormHandle: THandle;
begin
  Result := (Owner as TForm).Handle;
end;

// custom window procedure

procedure TDdhFormExt.NewWndMethod (var Msg: TMessage);
var
  ix, iy: Integer;
  ClientWidth, ClientHeight: Integer;
  BmpWidth, BmpHeight: Integer;
  hCanvas, BmpCanvas: THandle;
  pMinMax: PMinMaxInfo;
begin
  case Msg.Msg of
    wm_EraseBkgnd:
      if (fBackBitmap.Height <> 0) or
        (fBackBitmap.Width <> 0) then
      begin
        ClientWidth := (Owner as TForm).ClientWidth;
        ClientHeight := (Owner as TForm).ClientHeight;
        BmpWidth := fBackBitmap.Width;
        BmpHeight := fBackBitmap.Height;
        BmpCanvas := fBackBitmap.Canvas.Handle;
        hCanvas := THandle (Msg.wParam);
        for iy := 0 to ClientHeight div BmpHeight do
          for ix := 0 to ClientWidth div BmpWidth do
            BitBlt (hCanvas, ix * BmpWidth, iy * BmpHeight,
              BmpWidth, BmpHeight, BmpCanvas,
              0, 0, SRCCOPY);
        Msg.Result := 1; // message handled
        Exit; // skip default processing
      end;
    wm_GetMinMaxInfo:
      if fMaximizedWidth + fMaximizedHeight + fMaximizedPosX +
        fMaximizedPosY + fMinimumTrackWidth + fMinimumTrackHeight +
        fMaximumTrackWidth + fMaximumTrackHeight <> 0 then
      begin
        pMinMax := PMinMaxInfo (Msg.lParam);
        if fMaximizedWidth <> 0 then
          pMinMax.ptMaxSize.X := fMaximizedWidth;
        if fMaximizedHeight <> 0 then
          pMinMax.ptMaxSize.Y := fMaximizedHeight;
        if fMaximizedPosX <> 0 then
          pMinMax.ptMaxPosition.X := fMaximizedPosX;
        if fMaximizedPosY <> 0 then
          pMinMax.ptMaxPosition.Y := fMaximizedPosY;
        if fMinimumTrackWidth <> 0 then
          pMinMax.ptMinTrackSize.X := fMinimumTrackWidth;
        if fMinimumTrackHeight <> 0 then
          pMinMax.ptMinTrackSize.Y := fMinimumTrackHeight;
        if fMaximumTrackWidth <> 0 then
          pMinMax.ptMaxTrackSize.X := fMaximumTrackWidth;
        if fMaximumTrackHeight <> 0 then
          pMinMax.ptMaxTrackSize.Y := fMaximumTrackHeight;
        Msg.Result := 0; // message handled
        Exit; // skip default processing
      end;
  end;
  // call the default window procedure for every message
  Msg.Result := CallWindowProc (OldWndProc,
    FormHandle, Msg.Msg, Msg.WParam, Msg.LParam);
end;

// property related methods

procedure TDdhFormExt.SetBackBitmap(Value: TBitmap);
begin
  fBackBitmap.Assign (Value);
end;

procedure TDdhFormExt.BackBitmapChanged (Sender: TObject);
begin
  (Owner as TForm).Invalidate;
end;

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

end.

DDHROUND_PAS.HTM

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.

DDHSIZER_PAS.HTM

unit DdhSizer;

interface

uses
   Classes, Windows, Messages, Controls, StdCtrls;

const
  sc_DragMove: Longint = $F012;

type
  TDdhSizeButton = class (TButton)
  public
    procedure WmNcHitTest (var Msg: TWmNcHitTest);
      message wm_NcHitTest;
  end;

  TDdhSizerControl = class (TCustomControl)
  private
    FControl: TControl;
    FRectList: array [1..8] of TRect;
    FPosList: array [1..8] of Integer;
  public
    constructor Create (AOwner: TComponent;
      AControl: TControl);
    procedure CreateParams (var Params: TCreateParams);
      override;
    procedure CreateHandle; override;
    procedure WmNcHitTest (var Msg: TWmNcHitTest);
      message wm_NcHitTest;
    procedure WmSize (var Msg: TWmSize);
      message wm_Size;
    procedure WmLButtonDown (var Msg: TWmLButtonDown);
      message wm_LButtonDown;
    procedure WmMove (var Msg: TWmMove);
      message wm_Move;
    procedure Paint; override;
    procedure SizerControlExit (Sender: TObject);
  end;

procedure Register;

implementation

uses
  Graphics;

// TDdhSizeButton methods

procedure TDdhSizeButton.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
begin
  Pt := Point (Msg.XPos, Msg.YPos);
  Pt := ScreenToClient (Pt);
  if (Pt.x < 5) and (pt.y < 5) then
    Msg.Result := htTopLeft
  else if (Pt.x > Width - 5) and (pt.y < 5) then
    Msg.Result := htTopRight
  else if (Pt.x > Width - 5) and (pt.y > Height - 5) then
    Msg.Result := htBottomRight
  else if (Pt.x < 5) and (pt.y > Height - 5) then
    Msg.Result := htBottomLeft
  else if (Pt.x < 5) then
    Msg.Result := htLeft
  else if (pt.y < 5) then
    Msg.Result := htTop
  else if (Pt.x > Width - 5) then
    Msg.Result := htRight
  else if (pt.y > Height - 5) then
    Msg.Result := htBottom
  else
    inherited;
end;

// TDdhSizerControl methods

constructor TDdhSizerControl.Create (
  AOwner: TComponent; AControl: TControl);
var
  R: TRect;
begin
  inherited Create (AOwner);
  FControl := AControl;
  // install the new handler
  OnExit := SizerControlExit;
  // set the size and position
  R := FControl.BoundsRect;
  InflateRect (R, 2, 2);
  BoundsRect := R;
  // set the parent
  Parent := FControl.Parent;
  // create the list of positions
  FPosList [1] := htTopLeft;
  FPosList [2] := htTop;
  FPosList [3] := htTopRight;
  FPosList [4] := htRight;
  FPosList [5] := htBottomRight;
  FPosList [6] := htBottom;
  FPosList [7] := htBottomLeft;
  FPosList [8] := htLeft;
end;

procedure TDdhSizerControl.CreateHandle;
begin
  inherited CreateHandle;
  SetFocus;
end;

procedure TDdhSizerControl.CreateParams (var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.ExStyle := Params.ExStyle +
    ws_ex_Transparent;
end;

procedure TDdhSizerControl.Paint;
var
  I: Integer;
begin
  Canvas.Brush.Color := clBlack;
  for I := 1 to  8 do
    Canvas.Rectangle (FRectList [I].Left, FRectList [I].Top,
      FRectList [I].Right, FRectList [I].Bottom);
end;

procedure TDdhSizerControl.WmNcHitTest(var Msg: TWmNcHitTest);
var
  Pt: TPoint;
  I: Integer;
begin
  Pt := Point (Msg.XPos, Msg.YPos);
  Pt := ScreenToClient (Pt);
  Msg.Result := 0;
  for I := 1 to  8 do
    if PtInRect (FRectList [I], Pt) then
      Msg.Result := FPosList [I];
  // if the return value was not set
  if Msg.Result = 0 then
    inherited;
end;

procedure TDdhSizerControl.WmSize (var Msg: TWmSize);
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect (R, -2, -2);
  FControl.BoundsRect := R;
  // setup data structures
  FRectList [1] := Rect (0, 0, 5, 5);
  FRectList [2] := Rect (Width div 2 - 3, 0,
    Width div 2 + 2, 5);
  FRectList [3] := Rect (Width - 5, 0, Width, 5);
  FRectList [4] := Rect (Width - 5, Height div 2 - 3,
   Width, Height div 2 + 2);
  FRectList [5] := Rect (Width - 5, Height - 5,
   Width, Height);
  FRectList [6] := Rect (Width div 2 - 3, Height - 5,
    Width div 2 + 2, Height);
  FRectList [7] := Rect (0, Height - 5, 5, Height);
  FRectList [8] := Rect (0, Height div 2 - 3,
   5, Height div 2 + 2);
end;

procedure TDdhSizerControl.SizerControlExit (Sender: TObject);
begin
  Free;
end;

procedure TDdhSizerControl.WmLButtonDown (var Msg: TWmLButtonDown);
begin
  Perform (wm_SysCommand, sc_DragMove, 0);
end;

procedure TDdhSizerControl.WmMove (var Msg: TWmMove);
var
  R: TRect;
begin
  R := BoundsRect;
  InflateRect (R, -2, -2);
  FControl.Invalidate; // repaint entire surface
  FControl.BoundsRect := R;
end;

// components registration

procedure Register;
begin
  RegisterComponents ('DDHB', [TDdhSizeButton]);
  RegisterNoIcon ([TDdhSizerControl]);
end;

end.

DDHSTAR_PAS.HTM

unit DdhStar;

interface

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

type
  TDdhStar = class (TCustomControl)
  private
    {data fields for properties}
    fLineColor: TColor;
    fLineSize: Integer;
    fLinesVisible: Boolean;
    Pts: array [0..5] of TPoint;
  protected
    {set and get methods}
    procedure SetLineColor (Value: TColor);
    procedure SetLineSize (Value: Integer);
    procedure SetLinesVisible (Value: Boolean);
  public
    constructor Create (AOwner: TComponent); override;
    procedure CreateHandle; override;
    procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure Paint; override;
  published
    property LineColor: TColor
      read fLineColor write SetLineColor default clBlack;
    property LineSize: Integer
      read fLineSize write SetLineSize default 2;
    property LinesVisible: Boolean
      read fLinesVisible write SetLinesVisible default False;
    property Width default 50;
    property Height default 50;
  end;

procedure Register;

implementation

constructor TDdhStar.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  // set default values
  fLineColor := clBlack;
  fLineSize := 2;
  fLinesVisible := False;
  Width := 50;
  Height := 50;
end;

procedure TDdhStar.SetBounds (ALeft, ATop, AWidth, AHeight: Integer);
var
  HRegion1: THandle;
begin
  inherited;
  // compute points
  Pts [0] := Point (AWidth div 2, 0);
  Pts [1] := Point (AWidth, AHeight);
  Pts [2] := Point (0, AHeight div 3);
  Pts [3] := Point (AWidth, AHeight div 3);
  Pts [4] := Point (0, AHeight);
  Pts [5] := Point (Width div 2, 0);
  // set component shape
  if HandleAllocated then
  begin
    HRegion1 := CreatePolygonRgn (Pts,
      sizeof (Pts) div 8, winding);
    SetWindowRgn (Handle, HRegion1, True);
  end;
end;

procedure TDdhStar.CreateHandle;
var
  HRegion1: THandle;
begin
  inherited;
  HRegion1 := CreatePolygonRgn (Pts,
    sizeof (Pts) div 8, winding);
  SetWindowRgn (Handle, HRegion1, True);
end;

procedure TDdhStar.Paint;
begin
  Canvas.Brush.Color := clYellow;
  if fLinesVisible then
  begin
    Canvas.Pen.Color := fLineColor;
    Canvas.Pen.Width := fLineSize;
    SetPolyFillMode (Canvas.Handle, winding);
    Canvas.Polygon (Pts);
  end
  else
  begin
    Canvas.Pen.Width := 1;
    Canvas.Rectangle (-1, -1, Width + 1, Height + 1);
  end;
end;

{property access functions}

procedure TDdhStar.SetLineColor(Value: TColor);
begin
  if Value <> fLineColor then
  begin
    fLineColor := Value;
    Invalidate;
  end;
end;

procedure TDdhStar.SetLineSize(Value: Integer);
begin
  if Value <> fLineSize then
  begin
    fLineSize := Value;
    Invalidate;
  end;
end;

procedure TDdhStar.SetLinesVisible(Value: Boolean);
begin
  if Value <> fLinesVisible then
  begin
    fLinesVisible := Value;
    Invalidate;
  end;
end;

{$R ddhstar.dcr}

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

end.

Загрузить библиотеку компонент

Источник получения информации: http://www.delphiworld.narod.ru