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;
var
NewHint : TNewHint;
implementation
const
SHADOW_WIDTH = 6;
N_PIXELS = 5;
var
MemBmp: TBitmap;
UpRect, DownRect: TRect;
SelectHintDirection: THintDirection;
ShowPos: TPoint;
procedure Register;
begin
RegisterComponents('standard', [TDanHint]);
end;
procedure TDanHint.SetNewHintFont;
var
I: Integer;
begin
for I := 0 to Application.ComponentCount - 1 do
if Application.Components[I] is TNewHint then
begin
TNewHint(Application.Components[I]).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[I] is TDanHint then
begin
Result := TDanHint(Application.MainForm.Components[I]);
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.
浙公网安备 33010602011771号