自定义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;

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.

盒子论坛：http://bbs.2ccc.com/topic.asp?topicid=289749