定时显示提示信息（TToolTip）

{
    修改者：ghs
    日期：20071218
    功能：在原版本的基础上增加。
          RegisterControl：注册需要提示的控件。
          BeginHelp：设置光标状态为帮助crHelp；
          鼠标弹起后，显示注册的提示信息，同时光标进行还原。

   原版本
   作者：thaoqi
   出处：http://www.2ccc.com/article.asp?articleid=4389
   功能：首先谢谢xsherry大大，来盒子很长一段时间了，老是下东西，没有为盒子做什么贡献。
        前段时间xsherry大大抛砖引玉的文章，给我启发很大，最近一个项目提出要求人
        机交互界面更加有好，尽量少用MessageBox，所以在他的基础上，我试图模仿XP
        登录时候的那个ToolTip提示功能，用API摸索出一个符合要求的ToolTip提示框出
        来，最后我把实现的函数封装成了一个VCL的控件，希望大家能多提意见！
}
unit TooltipUtil;

interface

uses Messages, Windows, SysUtils, Classes, Contnrs, Controls, CommCtrl,
  StdCtrls, ExtCtrls, Consts, Forms, Dialogs, AppEvnts;

type
  TTipTool_ICON = (ttNoneIcon, ttInformationIcon, ttWarningIcon, ttStopIcon);
  TTipAlignment = (taLeft, taCenter, taRight);

  PTipInfo = ^TTipInfo;

  TTipInfo = packed record
    WinControl: TWinControl;
    Handle: THandle;
    Caption: string;
    Msg: string;
    TipICON: TTipTool_ICON;
    TipAlg: TTipAlignment;
    Cursor: TCursor;
  end;

  TToolTip = class(TComponent)
  private
    fTitle: string;
    fText: string;
    fEnabled: Boolean;
    fWindowHandle: HWND;
    fTipHandle: HWND;
    fInterval: Cardinal;
    fToolInfo: TToolInfo;
    fAlignment: TTipAlignment;
    fTipIcon: TTipTool_ICON;
    fControl: TWinControl;
    //
    Flist: TList;
    ApplicationEvents: TApplicationEvents;
    FLastHandle: THandle;

    procedure SetText(AText: string); //设置气泡提示信息
    procedure SetTitle(ATitle: string); //设置气泡提示的标题

    procedure UpdateTime; //更新计时器状态
    procedure WndProc(var Msg: TMessage); //接收windows消息
  protected
    //拦截消息=处理左键弹起
    procedure ApplicationEvents1Message(var Msg: tagMSG;
      var Handled: Boolean);
    //结束帮助=设置光标为控件本来状态
    procedure EndHelp;
  public
    constructor Create(AOwner: TComponent); override; //构造函数，创建实例
    destructor Destroy; override; //析构函数，销毁实例
    //注册控件信息
    procedure RegisterControl(WinControl: TWinControl; aCaption, aMsg: string;
      TipICON: TTipTool_ICON = ttInformationIcon; TipAlignment: TTipAlignment = taLeft);
    //开始帮助=设置光标状态
    procedure BeginHelp;
    procedure Popup(Handle: HWND); overload; //在指定的句柄中弹出气泡（重载）
    procedure Popup(Handle: HWND; IconType: TTipTool_ICON; Title,
      Text: string); overload; //在指定的句柄中弹出气泡（重载）

  published
      //气泡窗体的窗体句柄
    property Handle: HWND read fTipHandle;
      //气泡窗体的提示信息
    property Text: string read fText write SetText;
      //气泡窗体的标题信息
    property Title: string read fTitle write SetTitle;
      //气泡窗体的信息图标
    property ICON: TTipTool_ICON read fTipIcon write fTipIcon;
      //气泡窗体弹出时对齐位置
    property Alignment: TTipAlignment read fAlignment write fAlignment default taLeft;
      //气泡窗体的显示时间
    property Interval: Cardinal read fInterval write fInterval default ;
  end;

procedure Register;

implementation

const
  TTS_BALLOON = $; //ToolTip提示窗口的外形，指定为气球型
  TTS_CLOSE = $; //关闭按钮
  TTF_PARSELINKS = $; //可使用超链接
  TTM_SETTITLE = WM_USER + ; //社这提示标题信息的消息

constructor TToolTip.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  if not (AOwner is TWinControl) then
  begin
    raise exception.Create('TToolTip''s owner must be a ''TWinControl'' type.');
    Destroy;
  end;

  fWindowHandle := Classes.AllocateHWnd(WndProc);

  fEnabled := False;
  fInterval := ;

  //创建气泡提示窗口
  fTipHandle := CreateWindow(TOOLTIPS_CLASS, nil,
    WS_POPUP or TTS_NOPREFIX or
    TTS_BALLOON or TTS_ALWAYSTIP, // or TTS_CLOSE,
    , , , , fWindowHandle,
    , HInstance, nil);

  if fTipHandle <>  then
  begin
    //设置ToolInfo的大小
    fToolInfo.cbSize := SizeOf(fToolInfo);
    //设置基本风格
    fToolInfo.uFlags := TTF_PARSELINKS or TTF_IDISHWND or TTF_TRACK;
    //设置所有者的句柄
    fToolInfo.uId := fWindowHandle;
  end;
  Flist := TList.Create;
  ApplicationEvents := TApplicationEvents.Create(nil);
  ApplicationEvents.OnMessage := ApplicationEvents1Message;
end;

destructor TToolTip.Destroy;
var
  I: Integer;
  tmpTipInfo: PTipInfo;
begin
  if fTipHandle <>  then
    CloseWindow(fTipHandle);
  for I := Flist.Count -  downto  do    // Iterate
  begin
    tmpTipInfo := PTipInfo(FList.Items[i]);
    Dispose(tmpTipInfo);
  end;    // for
  Flist.Free;
  ApplicationEvents.Free;
  inherited Destroy;
end;

procedure TToolTip.SetText(AText: string);
begin
  fText := AText;

  if fTipHandle <>  then
  begin
    //设置标题信息
    fToolInfo.lpszText := PAnsiChar(fText);
    //向气泡窗体发送消息，将ToolInfo的信息设置到气泡窗体中
    SendMessage(fTipHandle, TTM_ADDTOOL, , Integer(@fToolInfo));
    SendMessage(fTipHandle, TTM_SETTOOLINFO, , Integer(@fToolInfo));
  end;
end;

procedure TToolTip.SetTitle(ATitle: string);
begin
  fTitle := ATitle;

  if fTipHandle <>  then
    //设置气泡窗体的提示图标和标题信息
    SendMessage(fTipHandle, TTM_SETTITLE, Integer(fTipIcon), Integer(fTitle));
end;

procedure TToolTip.Popup(Handle: HWND);
var
  tmpRect: TRect;
  x, y: word;
begin
  x := ;

  fControl := FindControl(Handle);
  if fControl.Hint <> '' then
    fControl.ShowHint := False;

  //得到需要显示窗体所在的屏幕区域
  GetWindowRect(Handle, tmpRect);

  //计算显示区域位置的坐标
  with tmpRect do
  begin
    y := (Bottom - Top) div  + Top;

    case fAlignment of
      taLeft: x := Left;
      taCenter: x := (Right - Left) div  + Left;
      taRight: x := Right;
    end;
  end;

  //设置气泡窗体弹出的坐标
  SendMessage(fTipHandle, TTM_TRACKPOSITION, , MAKELONG(x, y));
  //激活气泡窗体，并显示出来
  SendMessage(fTipHandle, TTM_TRACKACTIVATE, Integer(True), Integer(@fToolInfo));

  fEnabled := True;
  //更新计时器状态
  UpdateTime;
end;

procedure TToolTip.WndProc(var Msg: TMessage);
begin
  fEnabled := False;

  with Msg do
  begin
    case Msg of
      WM_TIMER:
      try
        SendMessage(fTipHandle, TTM_TRACKACTIVATE,
          Integer(False), Integer(@fToolInfo));
        if fControl.Hint <> '' then
          fControl.ShowHint := True;
      except
        Application.HandleException(Self);
      end;
    else
      Result := DefWindowProc(fWindowHandle, Msg, wParam, lParam);
    end;
  end;
  //更新计时器状态
  UpdateTime;
end;

procedure TToolTip.Popup(Handle: HWND; IconType: TTipTool_ICON;
  Title: string; Text: string);
begin
  fTipIcon := IconType;

  SetTitle(Title);
  SetText(Text);

  Popup(Handle);
end;

procedure TToolTip.UpdateTime;
begin
  KillTimer(fWindowHandle, );
  if (FInterval <> ) and FEnabled then
    if SetTimer(fWindowHandle, , FInterval, nil) =  then
      raise EOutOfResources.Create(SNoTimers);
end;

procedure Register;
begin
  RegisterComponents('ToolTip', [TToolTip]);
end;

procedure TToolTip.RegisterControl(WinControl: TWinControl; aCaption, aMsg: string;
  TipICON: TTipTool_ICON = ttInformationIcon; TipAlignment: TTipAlignment = taLeft);
var
  TipInfo: PTipInfo;
begin
  New(TipInfo);
  TipInfo.WinControl := WinControl;
  TipInfo.Handle := WinControl.Handle;
  TipInfo.Caption := aCaption;
  Tipinfo.Msg := aMsg;
  TipInfo.TipICON := TipICON;
  TIpInfo.TipAlg := TipAlignment;
  TipInfo.Cursor := WinControl.Cursor;

  Flist.Add(TipInfo);
end;

procedure TToolTip.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  I: Integer;
  tmpTipInfo: PTipInfo;
  tmpPoint: TPoint;
  tmpHandle: THandle;
begin
  if Msg.message = WM_LBUTTONUP then
  begin
    GetCurSorPos(tmpPoint);
    tmpHandle := WindowFromPoint(tmpPoint);
    if FLastHandle <> tmpHandle then //防止不停触发
    begin
      FLastHandle := tmpHandle;
      for I :=  to FList.Count -  do    // Iterate
      begin
        tmpTipInfo := PTipInfo(FList.Items[i]);
        //只有调用了BeginHelp，才会弹出提示窗口
        if (tmpTipInfo.Handle = tmpHandle) and (tmpTipInfo.WinControl.Cursor = crHelp) then
        begin
          Popup(tmpHandle, tmpTipInfo.TipICON, tmpTipInfo.Caption, tmpTipInfo.Msg);
          break;
        end;
      end;    // for
      EndHelp;
      DefWindowProc(Msg.hwnd, Msg.message, Msg.wParam, Msg.lParam);
    end;
  end;

end;

procedure TToolTip.BeginHelp;
var
  i: Integer;
  tmpTipInfo: PTipInfo;
begin
  for I :=  to FList.Count -  do    // Iterate
  begin
    tmpTipInfo := PTipInfo(FList.Items[i]);
    tmpTipInfo.WinControl.Cursor := crHelp;
  end;    // for
end;

procedure TToolTip.EndHelp;
var
  i: Integer;
  tmpTipInfo: PTipInfo;
begin
  for I :=  to FList.Count -  do    // Iterate
  begin
    tmpTipInfo := PTipInfo(FList.Items[i]);
    tmpTipInfo.WinControl.Cursor := tmpTipInfo.Cursor;
  end;    // for
end;

end.

调用一:

if edt3.Text='' then
  begin
    tltp1.Popup(TWinControl(edt3).Handle, ttStopIcon,'提示','请输入产地');
    Exit;
  end;

调用二:

ToolTip1.RegisterControl(LabeledEdit1, '提示', '请输入用户名');
ToolTip1.BeginHelp;