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?
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.
来源：https://stackoverflow.com/questions/13679089/delphi-thintwindow-how-to-draw-a-transparent-png