定时显示提示信息（TToolTip）

转载过来的，文章出自：

http://www.delphifans.com/infoview/Article_3640.html

{
    修改者：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   1000 ;
   end ;

procedure  Register;

implementation

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

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 : =   1000 ;

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

   if  fTipHandle  <>   0   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  <>   0   then
    CloseWindow(fTipHandle);
   for  I : =  Flist.Count  -   1   downto   0   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  <>   0   then
   begin
     // 设置标题信息
    fToolInfo.lpszText : =  PAnsiChar(fText);
     // 向气泡窗体发送消息，将ToolInfo的信息设置到气泡窗体中
    SendMessage(fTipHandle, TTM_ADDTOOL,  0 , Integer(@fToolInfo));
    SendMessage(fTipHandle, TTM_SETTOOLINFO,  0 , Integer(@fToolInfo));
   end ;
end ;

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

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

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

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

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

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

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

   // 设置气泡窗体弹出的坐标
  SendMessage(fTipHandle, TTM_TRACKPOSITION,  0 , 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,  1 );
   if  (FInterval  <>   0 )  and  FEnabled  then
     if  SetTimer(fWindowHandle,  1 , FInterval,  nil )  =   0   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 : =   0   to  FList.Count  -   1   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 : =   0   to  FList.Count  -   1   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 : =   0   to  FList.Count  -   1   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;