创建气泡式提示

  • A+
所属分类:[开发技巧]

{首先我们定义好程序中使用的几个常量和变量,关于它们的功能在下面具体代码中有所说明。}
uses Windows, Messages, Commctrl;
const
TTS_BALLOON = ;
TTM_SETTITLE = (WM_USER + 32);
bitNone = 0;
bitInfo = 1;
bitWarning = 2;
bitError = 3;
var
hTooltip: Cardinal;
ti: TToolInfo;
buffer: array[0..255] of char;
{我们要使用API函数CreateWindowEx创建一个具有扩展风格的子窗口作为飞跃提示用,然后用SetWindowPos函数设置该子窗口的位置和大小。有关API函数CreateWindowEx和SetWindowPos的详细参数与功能说明请查阅MSDN或其他API书籍,本文就不再详述。这样我们可以定义如下的过程创建飞跃提示窗口(hToolTip):}
procedure CreateToolTips(hWnd: Cardinal);
begin
hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil,
TTS_ALWAYSTIP or TTS_BALLOON,
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT),
hWnd, 0, hInstance, nil);
if hToolTip <> 0 then
begin
SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
ti.cbSize := SizeOf(TToolInfo);
ti.uFlags := TTF_SUBCLASS;
ti.hInst := hInstance;
end;
end;
{注意CreateToolTips过程的hWnd参数就是你设计程序窗体的句柄。为了调用方便起见,下面再定义一个过程AddToolTip用于实现飞跃提示——包括提示的标题、内容、图标等项目。}
procedure AddToolTip(hwnd: DWORD; IconType: Integer; Text, Title: PChar);
var
Item: THandle;
Rect: TRect;
lpti: PToolInfo;
begin
Item := hWnd;
lpti := @ti;
if (Item <> 0) and (GetClientRect(Item, Rect)) then
begin
lpti.hwnd := Item;
lpti.Rect := Rect;
lpti.lpszText := Text;
SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
FillChar(buffer, SizeOf(buffer), #0);
lstrcpy(buffer, Title);
if (IconType > 3)
or (IconType < 0) then
IconType := 0;
SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
end;
end;
{ 注意上面的AddToolTip过程,第一个参数hwnd是指需要实现漫画式飞跃提示的对象句柄,第二个参数是由CreateToolTips过程传递过来的指针,IconType参数是指飞跃提示的图标。
准备工作就绪以后,进一步在程序中实现漫画式飞跃提示的过程就变得很简单了。}
// 无图标的飞跃提示实现如下:
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, bitNone, '测试飞跃提示', '无图标提示');
end;
// 蓝色信息提示图标的飞跃提示实现如下:
procedure TForm1.Button2Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, bitInfo, '测试飞跃提示', '信息图标');
end;
// 黄色警告图标的飞跃提示实现如下:
procedure TForm1.Button3Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, bitWarning, '测试飞跃提示', '警告图标');
end;
// 红色错误图标的飞跃提示实现如下:
procedure TForm1.Button4Click(Sender: TObject);
begin
CreateToolTips(Form1.Handle);
AddToolTip(Memo1.Handle, bitError, '测试飞跃提示', '错误图标');
end;
{其实,还有很多的方法实现多姿多彩的飞跃提示,比如直接使用标签控件来模拟等,但是本文提供了一个创建窗口子类的方法,如果灵活使用,一定会使你的程序大方光彩。}

  • 我的微信
  • 这是我的微信扫一扫
  • weinxin
  • 我的微信公众号
  • 我的微信公众号扫一扫
  • weinxin
广告也精彩
avatar
广告也精彩

发表评论

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: