Хинт любой формы

Code:

unit CoolHint

interface

uses Windows, Classes, Controls, Forms, Messages, Graphics

type

TddgHintWindow = class(THintWindow)

private

FRegion: THandle

procedure FreeCurrentRegion

public

destructor Destroy override

procedure ActivateHint(Rect: TRect const AHint: string);override ;

procedure Paint; override ;

procedure CreateParams(var Params: TCreateParams); override ;

end

implementation

destructor TddgHintWindow.Destroy

begin

FreeCurrentRegion;

inherited Destroy;

end

procedure TddgHintWindow.CreateParams(var Params: TCreateParams)

{ We need to remove the border created on the Windows API-level }

{ when the window is created. }

begin

inherited CreateParams(Params) ;

Params.Style := Params.Style and not ws_Border // remove border ;

end;

procedure TddgHintWindow.FreeCurrentRegion

{ Regions, like other API objects, should be freed when you are }

{ through using them. Note, however, that you cannot delete a }

{ region which is currently set in a window, so this method sets }

{ the window region to 0 before deleting the region object. }

begin

if FRegion <>0 then

begin // if Region is alive...

SetWindowRgn(Handle, 0, True) // set win region to 0

DeleteObject(FRegion) // FRegion := 0 // zero out field

end

end

procedure TddgHintWindow.ActivateHint(Rect: TRect const AHint: string);

{ Called when the hint is activated by putting the mouse pointer }

{ above a control. }

begin

with Rect do

Right := Right + Canvas.TextWidth('WWWW') // add some slop

BoundsRect := Rect

FreeCurrentRegion

with BoundsRect do

{ Create a round rectangular region to display the hint window }

FRegion := CreateRoundRectRgn(0, 0, Width, Height, Width, Height)

if FRegion <>0 then

SetWindowRgn(Handle, FRegion, True) // set win region

inherited ActivateHint(Rect, AHint) // call inherited

end

procedure TddgHintWindow.Paint

{ This method gets called by the WM_PAINT handler. It is }

{ responsible for painting the hint window. }

var R: TRect

begin

R := ClientRect // get bounding rectangle

Inc(R.Left, 1) // move left side slightly

Canvas.Font.Color := clInfoText // set to proper color

{ paint string in the center of the round rect }

DrawText(Canvas.Handle, PChar(Caption), Length(Caption), R,

DT_NOPREFIX or DT_WORDBREAK or DT_CENTER or DT_VCENTER)

end

var

OldHintClass: THintWindowClass

function SetNewHintClass(AClass: THintWindowClass): THintWindowClass

var

DoShowHint: Boolean

begin

Result := HintWindowClass // return value is old hint

window

DoShowHint := Application.ShowHint

if DoShowHint then

Application.ShowHint := False // destroy old hint window

HintWindowClass := AClass // assign new hint window

if DoShowHint then

Application.ShowHint := True // create new hint window

end

initialization

OldHintClass := SetNewHintClass(TddgHintWindow)

finalization

SetNewHintClass(OldHintClass)

end.