Как разрисовать HINTS

unit HntUnit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

type TmyHint = class(THintWindow)
  private
    FActivating: Boolean;
    FBmp, FBmp0 :TBitmap;
  protected
    procedure Paint; override;
    function getBmp:TBitmap;
    procedure SetBmp(B :TBitmap);
    procedure Gradient(Col1, Col2: TColor; Bmp: TBitmap);
    procedure DoDrawText(var Rect: TRect; Flags: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ActivateHint(Rect: TRect; const AHint: string); override;
  published
    property Caption;
    property Picture:TBitmap read GetBmp write SetBmp;
end;

var 
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  HintWindowClass := TmyHint;
  Application.ShowHint := True;
end;

{ TmyHint }

procedure TmyHint.ActivateHint(Rect: TRect; const AHint: string);
begin
  FActivating := True;
  try
    Caption := AHint;
    Inc(Rect.Bottom, 14); // отступ снизу
    Rect.Right := Rect.Right + 20; // отступ справа
    UpdateBoundsRect(Rect);
    if Rect.Top + Height > Screen.DesktopHeight then
      Rect.Top := Screen.DesktopHeight - Height;
    if Rect.Left + Width > Screen.DesktopWidth then
      Rect.Left := Screen.DesktopWidth - Width;
    if Rect.Left < Screen.DesktopLeft then
      Rect.Left := Screen.DesktopLeft;
    if Rect.Bottom < Screen.DesktopTop then
      Rect.Bottom := Screen.DesktopTop;
    SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
      SWP_SHOWWINDOW or SWP_NOACTIVATE);
    Invalidate;
  finally
    FActivating := False;
  end;
  inherited;
end; 

constructor TmyHint.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
   FBmp := TBitmap.Create;
   FBmp0 := TBitmap.Create;
  with Canvas.Font do
  begin
   Name := 'Arial Narrow';
   Size := 12;
   Style := [fsBold];
   Color := clLime;
  end;
end;

destructor TmyHint.Destroy;
begin
  FBmp.Free;
  FBmp0.Free;
  inherited Destroy;
end;

procedure TmyHint.DoDrawText(var Rect: TRect; Flags: Integer);
var
  Text: string;
begin
  Text := '  ' + Caption + '  ';
  if (Flags and DT_CALCRECT <> 0) and (Text = '') then
   Text := Text + '     ';
  Flags := DrawTextBiDiModeFlags(Flags);
  if not Enabled then
  begin
    OffsetRect(Rect, 1, 1);
    Canvas.Font.Color := clBtnHighlight;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
    OffsetRect(Rect, -1, -1);
    Canvas.Font.Color := clBtnShadow;
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
  end
  else
    DrawText(Canvas.Handle, PChar(Text), Length(Text), Rect, Flags);
end;

function TmyHint.getBmp: TBitmap;
begin
 Result.Assign(FBmp);
end;

procedure TmyHint.Gradient(Col1, Col2: TColor; Bmp: TBitmap);
 type
   PixArray = array [1..3] of Byte;
 var
   i, big, rdiv, gdiv, bdiv, h, w: Integer;
   ts: TStringList;
   p: ^PixArray;
 begin
   rdiv := GetRValue(Col1) - GetRValue(Col2);
   gdiv := GetgValue(Col1) - GetgValue(Col2);
   bdiv := GetbValue(Col1) - GetbValue(Col2);

   bmp.PixelFormat := pf24Bit;

   for h := 0 to bmp.Height - 1 do
   begin
     p := bmp.ScanLine[h];
     for w := 0 to bmp.Width - 1 do
     begin
       p^[1] := GetBvalue(Col1) - Round((w / bmp.Width) * bdiv);
       p^[2] := GetGvalue(Col1) - Round((w / bmp.Width) * gdiv);
       p^[3] := GetRvalue(Col1) - Round((w / bmp.Width) * rdiv);
       Inc(p);
     end;
   end;
end;

procedure TmyHint.Paint;
var
  R: TRect;
begin
  R := ClientRect;
  Inc(R.Left, 2);
  Inc(R.Top, 2);

  with Canvas do
  begin
    if Not FBmp.Empty then
     Draw(2, (R.Bottom div 2) - (Fbmp.Height div 2), Fbmp)
    else
     begin
       FBmp0.FreeImage;
      with FBmp0 do
      begin
       Height := R.Bottom;
       Width := R.Right;
      end;
       Gradient(clYellow, clRed, FBmp0);
       Draw(0, 0, FBmp0)
     end;
  end;

  Canvas.Brush.Style := bsClear;
  DoDrawText(R, DT_EXPANDTABS);
end;

procedure TmyHint.SetBmp(B: TBitmap);
begin
 FBmp.FreeImage;
 FBmp.Assign(B);
 Invalidate;
end;

procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 Memo1.Hint := Memo1.Text;
end;

end.