一个Hint控件

unit Danhint;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs;
type
THintDirection=(hdUpRight,hdUpLeft,hdDownRight,hdDownLeft);
TOnSelectHintDirection=procedure(HintControl:TControl;var HintDirection:THintDirection) of object;
TDanHint = class(TComponent)
private
{ Private declarations }
FHintDirection:THintDirection;
FHintColor:TColor;
FHintShadowColor:TColor;
FHintFont:TFont;
FHintPauseTime:Integer;
FOnSelectHintDirection:TOnSelectHintDirection;
procedure SetHintDirection(Value:THintDirection);
procedure SetHintColor(Value:TColor);
procedure SetHintShadowColor(Value:TColor);
procedure SetHintFont(Value:TFont);
procedure CMFontChanged(var Message:TMessage); message CM_FONTCHANGED;
procedure SetHintPauseTime(Value:Integer);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure Loaded;override;
procedure SetNewHintFont;
published
{ Published declarations }
property HintDirection:THintDirection read FHintDirection write SetHintDirection default hdUpRight;
property HintColor:TColor read FHintColor write SetHintColor default clYellow;
property HintShadowColor:TColor read FHintShadowColor write SetHintShadowColor default clPurple;
property HintFont:TFont read FHintFont write SetHintFont;
property HintPauseTime:Integer read FHintPauseTime write SetHintPauseTime default 600;
property OnSelectHintDirection:TOnSelectHintDirection read FOnSelectHintDirection write FOnSelectHintDirection;
end;
TNewHint = class(THintWindow)
private
{ Private declarations }
FDanHint:TDanHint;
FHintDirection:THintDirection;
procedure SelectProperHintDirection(ARect:TRect);
procedure CheckUpRight(Spot:TPoint);
procedure CheckUpLeft(Spot:TPoint);
procedure CheckDownRight(Spot:TPoint);
procedure CheckDownLeft(Spot:TPoint);
function FindDanHint:TDanHint;
function FindCursorControl:TControl;
protected
{ Protected declarations }
procedure Paint;override;
procedure CreateParams(var Params: TCreateParams);override;
public
{ Public declarations }
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
procedure ActivateHint(Rect: TRect; const AHint: string);override;
property HintDirection:THintDirection read FHintDirection write FHintDirection default hdUpRight;
published
{ Published declarations }
end;
procedure Register;
implementation
const
SHADOW_WIDTH=6;
N_PIXELS=5;
var
MemBmp:TBitmap;
UpRect,DownRect:TRect;
SelectHintDirection:THintDirection;
ShowPos:TPoint;
procedure Register;
begin
RegisterComponents('ActiveX', [TDanHint]);
end;
procedure TDanHint.SetNewHintFont;
var
I:Integer;
begin
for I:=0 to Application.ComponentCount-1 do
if Application.Components is TNewHint then
begin
TNewHint(Application.Components).Canvas.Font.Assign(FHintFont);
Exit;
end;
end;
constructor TDanHint.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FHintDirection:=hdUpRight;
FHintColor:=clYellow;
{ $0080FFFF is Delphi's original setting }
FHintShadowColor:=clPurple;
FHintPauseTime:=600;
Application.HintPause:=FHintPauseTime;
FHintFont:=TFont.Create;
FHintFont.Name:='MS Sans Serif';
FHintFont.Size:=12;
FHintFont.Color:=clBlue;
FHintFont.Pitch:=fpDefault;
FHintFont.Style:=FHintFont.Style+[fsBold,fsItalic];
if not (csDesigning in ComponentState) then
begin
HintWindowClass:=TNewHint;
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ in TApplication's SetShowHint, the private
FHintWindow is allocated according to
HintWindowClass, so here do so actions to
call SetShowHint and keep ShowHint property
the same value }
SetNewHintFont;
end;
end;
destructor TDanHint.Destroy;
begin
FHintFont.Free;
inherited Destroy;
end;
procedure TDanHint.Loaded;
begin
if not (csDesigning in ComponentState) then
begin
inherited Loaded;
HintWindowClass:=TNewHint;
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ to activate to allocate a new Hint Window }
SetNewHintFont;
end;
end;
procedure TDanHint.SetHintDirection(Value:THintDirection);
begin
FHintDirection:=Value;
end;
procedure TDanHint.SetHintColor(Value:TColor);
begin
FHintColor:=Value;
end;
procedure TDanHint.SetHintShadowColor(Value:TColor);
begin
FHintShadowColor:=Value;
end;
procedure TDanHint.SetHintFont(Value:TFont);
begin
FHintFont.Assign(Value);
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ to activate to allocate a new Hint Window }
SetNewHintFont;
end;
procedure TDanHint.CMFontChanged(var Message:TMessage);
begin
inherited;
Application.ShowHint:=not Application.ShowHint;
Application.ShowHint:=not Application.ShowHint;
{ to activate to allocate a new Hint Window }
SetNewHintFont;
end;
procedure TDanHint.SetHintPauseTime(Value:Integer);
begin
if (Value<>FHintPauseTime) then
begin
FHintPauseTime:=Value;
Application.HintPause:=Value;
end;
end;
function TNewHint.FindDanHint:TDanHint;
var
I:Integer;
begin
Result:=nil;
for I:=0 to Application.MainForm.ComponentCount-1 do
if Application.MainForm.Components is TDanHint then
begin
Result:=TDanHint(Application.MainForm.Components);
Exit;
end;
end;
constructor TNewHint.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
{if (Application<>nil) and (Application.MainForm<>nil) then
FDanHint:=FindDanHint;}
ControlStyle:=ControlStyle-[csOpaque];
with Canvas do
begin
{ Font.Name:='MS Sans Serif';
Font.Size:=10;}
{if (FDanHint<>nil) then Font.Assign(FDanHint.HintFont);}
Brush.Style:=bsClear;
Brush.Color:=clBackground;
Application.HintColor:=clBackground;
end;
FHintDirection:=hdUpRight;
end;
destructor TNewHint.Destroy;
begin
inherited Destroy;
end;
procedure TNewHint.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
{Style := WS_POPUP or WS_BORDER or WS_DISABLED;}
Style := Style-WS_BORDER;
{ExStyle:=ExStyle or WS_EX_TRANSPARENT;}
{Add the above makes the beneath window overlap hint}
WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
end;
end;
procedure TNewHint.Paint;
var
R: TRect;
CCaption: array[0..255] of Char;
FillRegion,ShadowRgn:HRgn;
AP:array[0..2] of TPoint; { Points of the Arrow }
SP:array[0..2] of TPoint; { Points of the Shadow }
X,Y:Integer;
AddNum:Integer; { Added num for hdDownXXX }
begin
R := ClientRect;
{ R is for Text output }
Inc(R.Left,5+3);
Inc(R.Top,3);
AddNum:=0;
if FHintDirection>=hdDownRight then AddNum:=15;
Inc(R.Top,AddNum);
case HintDirection of
hdUpRight:begin
AP[0]:=Point(10,Height-15);
AP[1]:=Point(20,Height-15);
AP[2]:=Point(0,Height);
SP[0]:=Point(12,Height-15);
SP[1]:=Point(25,Height-15);
SP[2]:=Point(12,Height);
end;
hdUpLeft:begin
AP[0]:=Point(Width-SHADOW_WIDTH-20,Height-15);
AP[1]:=Point(Width-SHADOW_WIDTH-10,Height-15);
AP[2]:=Point(Width-SHADOW_WIDTH,Height);
SP[0]:=Point(Width-SHADOW_WIDTH-27,Height-15);
SP[1]:=Point(Width-SHADOW_WIDTH-5,Height-15);
SP[2]:=Point(Width-SHADOW_WIDTH,Height);
end;
hdDownRight:begin
AP[0]:=Point(10,15);
AP[1]:=Point(20,15);
AP[2]:=Point(0,0);
{ for hdDownXXX, SP not used now }
SP[0]:=Point(12,Height-15);
SP[1]:=Point(25,Height-15);
SP[2]:=Point(12,Height);
end;
hdDownLeft:begin
AP[0]:=Point(Width-SHADOW_WIDTH-20,15);
AP[1]:=Point(Width-SHADOW_WIDTH-10,15);
AP[2]:=Point(Width-SHADOW_WIDTH,0);
{ for hdDownXXX, SP not used now }
SP[0]:=Point(12,Height-15);
SP[1]:=Point(25,Height-15);
SP[2]:=Point(12,Height);
end;
end;
{ Draw Shadow of the Hint Rect}
if (FHintDirection<=hdUpLeft) then
begin
ShadowRgn:=CreateRoundRectRgn(0+10,0+8,Width,Height-9,8,8);
{ 8 is for RoundRect's corner }
for X:=Width-SHADOW_WIDTH-8 to Width do
for Y:=8 to Height-14 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
for X:=10 to Width do
for Y:=Height-14 to Height-9 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
end
else { for hdDownXXX }
begin
ShadowRgn:=CreateRoundRectRgn(0+10,0+8+15,Width,Height-2,8,8);
for X:=Width-SHADOW_WIDTH-8 to Width do
for Y:=23 to Height-8 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
for X:=10 to Width do
for Y:=Height-8 to Height-2 do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
end;
DeleteObject(ShadowRgn);
{ Draw the shadow of the arrow }
if (HintDirection<=hdUpLeft) then
begin
ShadowRgn:=CreatePolygonRgn(SP,3,WINDING);
for X:=SP[0].X to SP[1].X do
for Y:=SP[0].Y to SP[2].Y do
begin
if (Odd(X)=Odd(Y)) and PtInRegion(ShadowRgn,X,Y) then
MemBmp.Canvas.Pixels[X,Y]:=FDanHint.HintShadowColor;
end;
DeleteObject(ShadowRgn);
end;
{ Draw HintRect }
MemBmp.Canvas.Pen.Color:=clBlack;
MemBmp.Canvas.Pen.Style:=psSolid;
MemBmp.Canvas.Brush.Color:=FDanHint.HintColor;
MemBmp.Canvas.Brush.Style:=bsSolid;
if (FHintDirection<=hdUpLeft) then
MemBmp.Canvas.RoundRect(0,0,Width-SHADOW_WIDTH,Height-14,9,9)
else
MemBmp.Canvas.RoundRect(0,0+AddNum,Width-SHADOW_WIDTH,Height-14+6,9,9);
{ Draw Hint Arrow }
MemBmp.Canvas.Pen.Color:=FDanHint.HintColor;
MemBmp.Canvas.MoveTo(AP[0].X,AP[0].Y);
MemBmp.Canvas.LineTo(AP[1].X,AP[1].Y);
MemBmp.Canvas.Pen.Color:=clBlack;
FillRegion:=CreatePolygonRgn(AP,3,WINDING);
FillRgn(MemBmp.Canvas.Handle,FillRegion,MemBmp.Canvas.Brush.Handle);
DeleteObject(FillRegion);
MemBmp.Canvas.LineTo(AP[2].X,AP[2].Y);
MemBmp.Canvas.LineTo(AP[0].X,AP[0].Y);
{ SetBkMode makes DrawText's text be transparent }
SetBkMode(MemBmp.Canvas.Handle,TRANSPARENT);
MemBmp.Canvas.Font.Assign(FDanHint.HintFont);
DrawText(MemBmp.Canvas.Handle, StrPCopy(CCaption, Caption), -1, R,
DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);
Canvas.CopyMode:=cmSrcCopy;
Canvas.CopyRect(ClientRect,MemBmp.Canvas,ClientRect);
MemBmp.Free;
end;
procedure TNewHint.CheckUpLeft(Spot:TPoint);
var
Width,Height:Integer;
begin
Dec(Spot.Y,N_PIXELS);
Width:=UpRect.Right-UpRect.Left;
Height:=UpRect.Bottom-UpRect.Top;
SelectHintDirection:=hdUpLeft;
if (Spot.X+SHADOW_WIDTH-Width)<0 then
begin
Inc(Spot.Y,N_PIXELS);{back tp original}
CheckUpRight(Spot);
Exit;
end;
if (Spot.Y-Height)<0 then
begin
Inc(Spot.Y,N_PIXELS);
CheckDownLeft(Spot);
Exit;
end;
ShowPos.X:=Spot.X+SHADOW_WIDTH-Width;
ShowPos.Y:=Spot.Y-Height;
end;
procedure TNewHint.CheckUpRight(Spot:TPoint);
var
Width,Height:Integer;
begin
Dec(Spot.Y,N_PIXELS);
Width:=UpRect.Right-UpRect.Left;
Height:=UpRect.Bottom-UpRect.Top;
SelectHintDirection:=hdUpRight;
if (Spot.X+Width)>Screen.Width then
begin
Inc(Spot.Y,N_PIXELS);
CheckUpLeft(Spot);
Exit;
end;
if (Spot.Y-Height)<0 then
begin
Inc(Spot.Y,N_PIXELS);
CheckDownRight(Spot);
Exit;
end;
ShowPos.X:=Spot.X;
ShowPos.Y:=Spot.Y-Height;
end;
procedure TNewHint.CheckDownRight(Spot:TPoint);
var
Width,Height:Integer;
begin
Inc(Spot.Y,N_PIXELS*3);
Width:=DownRect.Right-DownRect.Left;
Height:=DownRect.Bottom-DownRect.Top;
SelectHintDirection:=hdDownRight;
if (Spot.X+Width)>Screen.Width then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckDownLeft(Spot);
Exit;
end;
if (Spot.Y+Height)>Screen.Height then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckUpRight(Spot);
Exit;
end;
ShowPos.X:=Spot.X;
ShowPos.Y:=Spot.Y;
end;
procedure TNewHint.CheckDownLeft(Spot:TPoint);
var
Width,Height:Integer;
begin
Inc(Spot.Y,N_PIXELS*3);
Width:=DownRect.Right-DownRect.Left;
Height:=DownRect.Bottom-DownRect.Top;
SelectHintDirection:=hdDownLeft;
if (Spot.X+SHADOW_WIDTH-Width)<0 then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckDownRight(Spot);
Exit;
end;
if (Spot.Y+Height)>Screen.Height then
begin
Dec(Spot.Y,N_PIXELS*3);
CheckUpLeft(Spot);
Exit;
end;
ShowPos.X:=Spot.X+SHADOW_WIDTH-Width;
ShowPos.Y:=Spot.Y;
end;
function TNewHint.FindCursorControl:TControl;
begin
{ControlAtPos}
end;
procedure TNewHint.SelectProperHintDirection(ARect:TRect);
var
Spot:TPoint;
OldHintDirection,SendHintDirection:THintDirection;
HintControl:TControl;
begin
GetCursorPos(Spot);
HintCOntrol:=FindDragTarget(Spot,True);
Inc(ARect.Right,10+SHADOW_WIDTH);
Inc(ARect.Bottom,20);
UpRect:=ARect;
Inc(ARect.Bottom,9);
DownRect:=ARect;
OldHintDirection:=FDanHint.HintDirection;
SendHintDirection:=FDanHint.HintDirection;
{ Tricky, why here can't use FDanHint.OnSe...? }
if Assigned(FDanHint.FOnSelectHintDirection) then
begin
FDanHint.FOnSelectHintDirection(HintControl,SendHintDirection);
FDanHint.HintDirection:=SendHintDirection;
end;
case FDanHint.HintDirection of
hdUpRight:CheckUpRight(Spot);
hdUpLeft:CheckUpLeft(Spot);
hdDownRight:CheckDownRight(Spot);
hdDownLeft:CheckDownLeft(Spot);
end;
FDanHint.HintDirection:=OldHintDirection;
end;
procedure TNewHint.ActivateHint(Rect: TRect; const AHint: string);
var
ScreenDC:HDC;
LeftTop:TPoint;
tmpWidth,tmpHeight:Integer;
begin
MemBmp:=TBitmap.Create;
Caption := AHint;
{ add by Dan from Here }
FDanHint:=FindDanHint;
SelectProperHintDirection(Rect);
HintDirection:=SelectHintDirection;
{ if the following changes, make sure to modify
SelectProperHintDirection also }
Inc(Rect.Right,10+SHADOW_WIDTH);
Inc(Rect.Bottom,20);
if (FHintDirection>=hdDownRight) then Inc(Rect.Bottom,9);
{ to expand the rect }
tmpWidth:=Rect.Right-Rect.Left;
tmpHeight:=Rect.Bottom-Rect.Top;
Rect.Left:=ShowPos.X;
Rect.Top:=ShowPos.Y;
Rect.Right:=Rect.Left+tmpWidth;
Rect.Bottom:=Rect.Top+tmpHeight;
BoundsRect := Rect;
MemBmp.Width:=Width;
MemBmp.Height:=Height;
ScreenDC:=CreateDC('DISPLAY',nil,nil,nil);
LeftTop.X:=0;
LeftTop.Y:=0;
LeftTop:=ClientToScreen(LeftTop);
{ use MemBmp to store the original bitmap
on screen }
BitBlt(MemBmp.Canvas.Handle,0,0,Width,Height,ScreenDC,
LeftTop.X,LeftTop.Y,SRCCOPY);
{ SetBkMode(Canvas.Handle,TRANSPARENT);}
SetWindowPos(Handle, HWND_TOPMOST, ShowPos.X, ShowPos.Y, 0,
0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
BitBlt(Canvas.Handle,0,0,Width,Height,MemBmp.Canvas.Handle,
0,0,SRCCOPY);
DeleteDC(ScreenDC);
end;
initialization
end.