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

Borland Delphi 4, Руководство разработчика", К. Пачеко и С.
Тейксер

З.Ы. Пристегните (uses CoolHint) к любой форме с hint'ами и любуйтесь
подсказками.

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.

Взято с сайта




Содержание раздела

---

---