定時顯示提示信息（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 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;