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