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



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.

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

Далее: Обзор некоторых особенностей элементов управления библиотеки FM20.DLL »»