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.