(Delphi THintWindow) How to draw a transparent PNG? - delphi

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:
I need to draw the PNG with the transparent borders. The image itself is here
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.