Реализация тени

unit Unit1;

interface

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

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

TMyHintWindowClass = class(THintWindow)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
procedure ActivateHint(Rect: TRect; const AHint: string); override;
function CalcHintRect(MaxWidth: Integer; const AHint: string;
AData: Pointer): TRect; override;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TMyHintWindowClass;
end;

{ TMyHintWindowClass }

procedure TMyHintWindowClass.ActivateHint(Rect: TRect;
const AHint: string);
const
shadow_size = 4;
var
r1,r2: HRGN;
i,j: integer;
begin
inherited ActivateHint(Rect,AHint);
r1 := CreateRectRgn(0,0,width-1,height-1);
r2 := CreateRectRgn(width-shadow_size-1,0,width-1,shadow_size);
CombineRgn(r1,r1,r2,RGN_XOR);
DeleteObject(r2);
r2 := CreateRectRgn(0,height-shadow_size-1,shadow_size,height-1);
CombineRgn(r1,r1,r2,RGN_XOR);
DeleteObject(r2);
for i := width-shadow_size-1 to width-2 do
for j := shadow_size to height-2 do
if (i+j) and 1 = 0 then begin
r2 := CreateRectRgn(i,j,i+1,j+1);
CombineRgn(r1,r1,r2,RGN_XOR);
DeleteObject(r2);
end;
for i := shadow_size to width-shadow_size-2 do
for j := height-shadow_size-1 to height-2 do
if (i+j) and 1 = 0 then begin
r2 := CreateRectRgn(i,j,i+1,j+1);
CombineRgn(r1,r1,r2,RGN_XOR);
DeleteObject(r2);
end;
SetWindowRgn(Handle,r1,true);
DeleteObject(r1);
end;

function TMyHintWindowClass.CalcHintRect(MaxWidth: Integer;
const AHint: string; AData: Pointer): TRect;
begin
Result := Rect(0,0,Canvas.TextWidth(AHint)+10*2,Canvas.TextHeight(AHint)+8*2);
end;

constructor TMyHintWindowClass.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;

procedure TMyHintWindowClass.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_POPUP;
end;

procedure TMyHintWindowClass.Paint;
const
shadow_size = 4;
var
i,j: integer;
rc: TRect;
begin
with Canvas do begin
Brush.Color := clInfoText;
FillRect(ClientRect);
Brush.Color := clInfoBk;
Pen.Color := clInfoText;
Rectangle(0,0,width-shadow_size-1,height-shadow_size-1);
rc := ClientRect;
dec(rc.Right,shadow_size+1);
dec(rc.Bottom,shadow_size+1);
Windows.DrawText(Handle,pChar(Caption),Length(Caption),rc,DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
end;

end.

unit Unit1;

interface

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

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

TMyHintWindowClass = class(THintWindow)
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
procedure ActivateHint(ARect: TRect; const AHint: string); override;
function CalcHintRect(MaxWidth: Integer; const AHint: string;
AData: Pointer): TRect; override;
end;

var
Form1: TForm1;
const
shadow_size = 5;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TMyHintWindowClass;
Application.HintPause := 0;
end;

{ TMyHintWindowClass }

procedure TMyHintWindowClass.ActivateHint(ARect: TRect;
const AHint: string);
var
rgn: HRGN;
i,j: integer;
hrc: DWORD;
rc: PRgnData;
rc_cnt: DWORD;
pr: PRect;
begin
inherited ActivateHint(ARect,AHint);
rc_cnt := 50;
hrc := GlobalAlloc(GMEM_MOVEABLE,sizeof(RGNDATAHEADER)+sizeof(TRect)*rc_cnt);
rc := GlobalLock(hrc);
with rc^.rdh do begin
dwSize := sizeof(rc^.rdh);
iType := RDH_RECTANGLES;
nCount := 1;
nRgnSize := 0;
rcBound := ClientRect;
end;
PRect(@rc^.Buffer)^ := ClientRect;
dec(PRect(@rc^.Buffer)^.Right,shadow_size+1);
dec(PRect(@rc^.Buffer)^.Bottom,shadow_size+1);
for i := shadow_size to width-1 do//width-shadow_size-1 to width-1 do
for j := shadow_size to height-1 do
if ((i+j) and 1 = 0) and not PtInRect(PRect(@rc^.Buffer)^,Point(i,j)) then begin
if rc^.rdh.nCount+1 > rc_cnt then begin
inc(rc_cnt,50);
GlobalUnlock(hrc);
hrc := GlobalReAlloc(DWORD(rc),sizeof(RGNDATAHEADER)+sizeof(TRect)*rc_cnt,GMEM_MOVEABLE);
rc := GlobalLock(hrc);
end;
pr := PRect(@rc^.Buffer);
inc(pr,rc^.rdh.nCount);
SetRect(pr^,i,j,i+1,j+1);
inc(rc^.rdh.nCount);
end;
rgn := ExtCreateRegion(nil,sizeof(RGNDATAHEADER)+(sizeof(TRect)*rc_cnt),rc^);
GlobalUnlock(hrc);
GlobalFree(DWORD(hrc));
SetWindowRgn(Handle,rgn,true);
DeleteObject(rgn);
end;

function TMyHintWindowClass.CalcHintRect(MaxWidth: Integer;
const AHint: string; AData: Pointer): TRect;
begin
Result := inherited CalcHintRect(MaxWidth,AHint,AData);
inc(Result.Right,5*2+shadow_size);
inc(Result.Bottom,5*2+shadow_size);
end;

constructor TMyHintWindowClass.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Color := clNone;
end;

procedure TMyHintWindowClass.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_POPUP;
end;

procedure TMyHintWindowClass.Paint;
var
rc: TRect;
begin
with Canvas do begin
Brush.Color := clInfoText;
FillRect(ClientRect);
Brush.Color := clInfoBk;
Pen.Color := clInfoText;
Rectangle(0,0,width-shadow_size-1,height-shadow_size-1);
rc := ClientRect;
dec(rc.Right,shadow_size+1);
dec(rc.Bottom,shadow_size+1);
InflateRect(rc,-7,-7);
Windows.DrawText(Handle,pChar(Caption),Length(Caption),rc,DT_LEFT or DT_WORDBREAK);
end;
end;

end.