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.
代码
