Question

I have this delphi 2010 code:

unit Unit1;

interface

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

type
     TMyHintWindow = class(THintWindow)
     private
      FBitmap : TBitmap;
      ThePNG  : TPngImage;
      FRegion : THandle;
      procedure FreeRegion;
     protected
      procedure CreateParams(var Params : TCreateParams); override;
      procedure Paint; override;
      procedure Erase(var Message : TMessage); message WM_ERASEBKGND;
     public
      constructor Create(AOwner : TComponent); override;
      destructor Destroy; override;
      procedure  ActivateHint(Rect : TRect; const AHint : String); Override;
     end;

type
    TForm1 = class(TForm)
    Button1: TButton;
     procedure FormCreate(Sender : TObject);
    private
     { Private declarations }
    public
     { Public declarations }
    end;

var
   Form1 : TForm1;

implementation

{$R *.dfm}
// --------------------------------------------------------------------------- //
constructor TMyHintWindow.Create(AOwner : TComponent);
begin
     inherited Create(AOwner);
     FBitmap                  := TBitmap.Create;

     FBitmap.PixelFormat      := pf32bit;
     FBitmap.HandleType       := bmDIB;
     FBitmap.Transparent      := True;
     FBitmap.TransparentMode  := tmAuto;  // }tmFixed;
     FBitmap.TransparentColor := clWhite;
     FBitmap.AlphaFormat      := {afPremultiplied;  // }afDefined;

     ThePNG                   := TPngImage.Create;
     ThePNG.Transparent       := True;
     ThePNG.TransparentColor  := clWhite;
     ThePNG.LoadFromFile('D:\project-1\tooltip.png');

     FBitmap.LoadFromFile('D:\project-1\tooltip.bmp');
end;
// --------------------------------------------------------------------------- //
destructor TMyHintWindow.Destroy;
begin
     FBitmap.Free;
     FreeRegion;

     inherited;
end;
// --------------------------------------------------------------------------- //
procedure TMyHintWindow.CreateParams(var Params : TCreateParams);
const
     CS_DROPSHADOW = $20000;
begin
     inherited;
     Params.Style := Params.Style - WS_BORDER;
     Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
// --------------------------------------------------------------------------- //
procedure TMyHintWindow.FreeRegion;
begin
     if FRegion <> 0 then
     begin
      SetWindowRgn(Handle, 0, True);
      DeleteObject(FRegion);
      FRegion := 0;
     end;
end;
// --------------------------------------------------------------------------- //
procedure TMyHintWindow.ActivateHint(Rect : TRect; const AHint : String);
var
   i : Integer;
begin
     Caption             := AHint;
     Canvas.Font         := Screen.HintFont;
     FBitmap.Canvas.Font := Screen.HintFont;
     DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, DT_CALCRECT or DT_NOPREFIX);

     Width               := 230;  // (Rect.Right - Rect.Left) + 16;
     Height              := 61;   // (Rect.Bottom - Rect.Top) + 10;

     FBitmap.Width       := Width;
     FBitmap.Height      := Height;
     Left := Rect.Left;
     Top := Rect.Top;
     FreeRegion;

     with Rect do
      FRegion := CreateRoundRectRgn(1, 1, Width, Height, 3, 3);

     if FRegion <> 0 then
    SetWindowRgn(Handle, FRegion, True);

     AnimateWindowProc(Handle, 300, AW_BLEND);

     SetWindowPos(Handle, HWND_TOPMOST, Left, Top, 0, 0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
end;
// --------------------------------------------------------------------------- //
procedure TMyHintWindow.Paint;
var
   CaptionRect : TRect;
begin
     with FBitmap.Canvas do
     begin
      Font.Color  := clWindowText;
      Brush.Style := bsClear;
     end;    // with
     CaptionRect := Rect(25, 26, Width - 10, Height - 10);

     SetBkMode(Canvas.Handle, TRANSPARENT);
     DrawText(FBitmap.Canvas.Handle, PChar(Caption), Length(Caption), CaptionRect, DT_WORDBREAK OR DT_NOPREFIX);
     BitBlt(Canvas.Handle, 0, 0, Width, Height, FBitmap.Canvas.Handle, 0, 0, SRCERASE{SRCCOPY});
end;
// --------------------------------------------------------------------------- //
procedure TMyHintWindow.Erase(var Message : TMessage);
begin
     Message.Result := 0;
end;
// --------------------------------------------------------------------------- //
procedure TForm1.FormCreate(Sender : TObject);
begin
     HintWindowClass := TMyHintWindow;
     Button1.Hint    := 'This is a nice fake tooltip!';
end;
// --------------------------------------------------------------------------- //
end.

This example has two issues:

1. I need to draw the PNG with the transparent borders. The image itself is here

2. If you run this project (form has just a button called Button1), and show the hint few times, you should realize that caption becomes bolder every time the hint is shown. I’m pretty sure I forgot a background I forgot to clear/erase, but I’m not sure how to fix that.

Can someone please tell me how to fix these two issues?

Answer 1

You will to have to perform adaption for position and png in cas of hint needed above, but the “engine” should work as expected. I didn’t use GDI+ which would i have made much easier.

unit Unit1;

interface

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

type
     TMyHintWindow = class(THintWindow)
     private
      FBitmap : TBitmap;
      ThePNG  : TPngImage;
      FCurrAlpha:Integer;
      FTimer:TTimer;
      FActivated:Boolean;
      FLastActive:Cardinal;
      procedure PrepareBitmap;
      procedure IncAlpha(Sender:TObject);
     protected
      procedure CreateParams(var Params : TCreateParams); override;
      procedure Paint; override;
      procedure Erase(var Message : TMessage); message WM_ERASEBKGND;
     public
      constructor Create(AOwner : TComponent); override;
      destructor Destroy; override;
      procedure  ActivateHint(Rect : TRect; const AHint : String); Override;
     end;

type
    TForm1 = class(TForm)
    Button1: TButton;

     procedure FormCreate(Sender : TObject);
    private
     { Private declarations }
    public
     { Public declarations }
    end;

var
   Form1 : TForm1;

implementation

{$R *.dfm}
// --------------------------------------------------------------------------- //
constructor TMyHintWindow.Create(AOwner : TComponent);
begin
     inherited Create(AOwner);
     FBitmap                  := TBitmap.Create;
     FCurrAlpha               := 1;
     FTimer                   := TTimer.Create(self);
     FTimer.Interval          := 20;
     Ftimer.OnTimer           := IncAlpha;
     Ftimer.Enabled           := false;
     ThePNG                   := TPngImage.Create;
     ThePNG.Transparent       := True;
     ThePNG.TransparentColor  := clWhite;
     ThePNG.LoadFromFile('C:\temp\0o36B.png');


end;
// --------------------------------------------------------------------------- //
destructor TMyHintWindow.Destroy;
begin
     FBitmap.Free;
     ThePNG.Free;
     inherited;
end;
// --------------------------------------------------------------------------- //

procedure TMyHintWindow.IncAlpha(Sender:TObject);
begin
    FCurrAlpha := FCurrAlpha + 10;
    if FCurrAlpha >= 254 then
        begin
           FCurrAlpha := 254;
           Ftimer.Enabled := false;
           FActivated := false;
        end;
    invalidate;
end;


procedure TMyHintWindow.CreateParams(var Params : TCreateParams);
const
     CS_DROPSHADOW = $20000;
begin
     inherited;
     Params.Style := Params.Style - WS_BORDER;
     Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
// --------------------------------------------------------------------------- //



type
  pRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = ARRAY[0..$effffff] OF TRGBQuad;
Procedure SetAlpha(bmp:TBitMap;Alpha:Byte);
var
 pscanLine32 : pRGBQuadArray;
 i,j:Integer;
 begin
   Bmp.PixelFormat := pf32Bit;
   bmp.HandleType := bmDIB;
   bmp.ignorepalette := true;
   bmp.alphaformat := afDefined;
   for i := 0 to bmp.Height -1 do
     begin
     pscanLine32 := bmp.Scanline[i];
     for j := 0 to bmp.Width -1 do
        begin
          pscanLine32[j].rgbReserved := Alpha;
          pscanLine32[j].rgbBlue := 0;
          pscanLine32[j].rgbRed := 0;
          pscanLine32[j].rgbGreen := 0;
        end;
     end;
 end;

Procedure ResetSetAlpha(bmp:TBitMap;r:Trect;Alpha:Byte);
var
 pscanLine32 : pRGBQuadArray;
 i,j:Integer;
 begin
   for i := 0 to bmp.Height -1 do
     begin
     pscanLine32 := bmp.Scanline[i];
     for j := 0 to bmp.Width -1 do
        begin
          if (i>=r.Top) and (i<=r.Bottom) and (j>=r.Left) and (j<=r.Right) then
                pscanLine32[j].rgbReserved := Alpha;
        end;
     end;
 end;


procedure TMyHintWindow.PrepareBitmap;
var
 r:TRect;
begin
   r := Clientrect;
   r.Top := r.Top + 10;
   InflateRect(r,-10,-10);
   FreeAndNil(FBitmap);
   FBitmap := TBitmap.Create;
   FBitmap.Width := 230;
   FBitmap.Height := 61;
   SetAlpha(FBitmap, 0);
   FBitmap.Canvas.Font := Screen.HintFont;
   FBitmap.Canvas.Brush.Style := bsClear;
   FBitmap.Canvas.Draw(0, 0, ThePNG);
   DrawText(FBitmap.Canvas.Handle, PChar(Caption), Length(Caption), r,DT_Center or DT_Wordbreak or DT_NOPREFIX);
   ResetSetAlpha(FBitmap,r,255);
end;

// --------------------------------------------------------------------------- //
procedure TMyHintWindow.ActivateHint(Rect : TRect; const AHint : String);
var
   i : Integer;

begin
    if (GetTickCount - FLastActive > 250) and (Length(AHint) < 100) then

     if not FActivated then
        begin
         FCurrAlpha := 1;
         FActivated := true;
         Caption             := AHint;
         Canvas.Font         := Screen.HintFont;
         Width               := 230;  // (Rect.Right - Rect.Left) + 16;
         Height              := 61;   // (Rect.Bottom - Rect.Top) + 10;
         Left := rect.Left  - Width div 2;
         Top := Rect.Top;
         Ftimer.Enabled := true;
         ShowWindow(Handle, SW_SHOWNOACTIVATE);
         SetWindowPos(Handle, HWND_TOPMOST, Left, Top, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
         invalidate;
        end;
    FLastActive := GetTickCount;
end;

// --------------------------------------------------------------------------- //
procedure TMyHintWindow.Paint;
var
   DestPoint, srcPoint:TPoint;
   winSize:TSize;
   DC         : HDC;
   blendfunc  : BLENDFUNCTION;

    Owner : HWnd;
    curWinStyle:Integer;

     exStyle:Dword;
begin

   PrepareBitmap;
   DC := GetDC(0);

   try
   winSize.cx := width;
   winSize.cy := Height;
   srcPoint.x := 0;
   srcPoint.y := 0;

   DestPoint := BoundsRect.TopLeft;

   exStyle := GetWindowLongA(handle, GWL_EXSTYLE);
   if (exStyle and WS_EX_LAYERED) = 0 then

    SetWindowLong(handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED );



   With blendFunc do
   begin
     AlphaFormat := 1; //=AC_SRC_ALPHA;
     BlendFlags := 0;
     BlendOp := AC_SRC_OVER;
     SourceConstantAlpha :=  FCurrAlpha;  // here you can set Alpha
   end;
   UpdateLayeredWindow(Handle, DC, @DestPoint, @winSize, FBitmap.Canvas.Handle,  @srcPoint,clBlack, @blendFunc, 2);//=ULW_ALPHA

   finally
      ReleaseDC(0, DC);
   end;


end;
// --------------------------------------------------------------------------- //
procedure TMyHintWindow.Erase(var Message : TMessage);
begin
     Message.Result := 0;
end;
// --------------------------------------------------------------------------- //
procedure TForm1.FormCreate(Sender : TObject);
begin
     HintWindowClass := TMyHintWindow;

     Button1.Hint    := 'This is a nice fake tooltip!';
     ReportMemoryLeaksOnShutDown := true;
end;
// --------------------------------------------------------------------------- //
end.