sherryhint.pas

Delphi气泡提示的实现

unit SherryHint;

interface

uses
  Windows, Messages, Classes, Controls, Forms, CommCtrl;

type
  THintWin=class(THintWindow)
  private
    FLastActive: THandle;
  public
    procedure ActivateHint(Rect:TRect;Const AHint:string);override;
  end;

implementation

procedure AddTipTool(hWnd: DWORD; IconType: Integer; Title, Text: PChar);
const
  TTS_BALLOON =$0040;
  TTM_SETTITLE=WM_USER + 32;
var
  hWndTip: DWORD;
  ToolInfo: TToolInfo;
begin
  hWndTip:=CreateWindow(TOOLTIPS_CLASS, nil,
          WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
          0, 0, 0, 0, hWnd, 0, HInstance, nil);
  if (hWndTip<>0) then
  begin
    ToolInfo.cbSize:=SizeOf(ToolInfo);
    ToolInfo.uFlags:=TTF_IDISHWND or TTF_SUBCLASS or TTF_TRANSPARENT;
    ToolInfo.uId:=hWnd;
    ToolInfo.lpszText:=Text;
    SendMessage(hWndTip,TTM_ADDTOOL,1,Integer(@ToolInfo));
    SendMessage(hWndTip,TTM_SETTITLE,IconType,Integer(Title));
  end;
  InitCommonControls();
end;

procedure THintWin.ActivateHint(Rect:TRect;const AHint:string);
begin
  if FLastActive<>WindowFromPoint(Mouse.CursorPos) then
  AddTipTool(WindowFromPoint(Mouse.CursorPos),1,'Sherry SoftWare', PChar(AHint));//Application.Hint));
  FLastActive:=WindowFromPoint(Mouse.CursorPos);
end;

initialization
 Application.HintPause:=0;
 Application.ShowHint:=False;
 HintWindowClass:=THintWin; 
 Application.ShowHint:=True;
end.