delphi 气泡提示

这是一个气泡提示的动态库.(参考网络资源 自己封装)

library BoolTip;

uses
SysUtils,
CommCtrl,
Windows,
Controls,
Classes;

{ $R *.res }
var
tI: TToolInfo;
buffer : array [ 0 .. 255 ] of char;

function CreateInfoTip(hWnd: THandle): THandle; stdcall ;
var
hToolTip: Cardinal;
begin
hToolTip : = CreateWindowEx( 0 , ' Tooltips_Class32 ' , nil , TTS_ALWAYSTIP or $ 40 ,
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 or TTF_TRANSPARENT;
tI.hInst : = hInstance;
end ;
Result : = hToolTip;
end ;

function ShowInfoTip(pTip: THandle; lpszText: PChar; pos:PPoint = nil ; icon:HICON = 0 ;
nDelay:Integer = 1000 ): Boolean; stdcall ;
var
Rect: TRect;
begin
FillChar(buffer, sizeof(buffer), # 0 );
lstrcpy(buffer, ' 提示 ' );
if pos = nil then Rect.BottomRight : = Mouse.CursorPos
else Rect.BottomRight : = Point(pos^.X,pos^.Y);
tI.hwnd : = WindowFromPoint(Mouse.CursorPos);
Rect.TopLeft : = Point( 0 , 0 );
tI.Rect : = Rect;
tI.lpszText : = lpszText;
SendMessage(pTip, TTM_ADDTOOL, 0 , Integer(@tI));
if (icon > 3 ) or (icon < 0 ) then icon : = 0 ;
// icon 0 : 默认 1 : 提示 2 : 感叹号 3 : 错误
SendMessage(pTip, $ 0400 + 32 , icon, Integer(@buffer));
// SendMessage(pTip, TTM_SETTIPBKCOLOR, $95E3FF, 0 ); // 设置背景色
// SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, clGreen , 0 ); // 设置字体颜色
Result : = True;
end ;

procedure DestroyInfoTip(pTip: THandle); stdcall ;
begin
DestroyWindow(pTip);
end ;

exports
CreateInfoTip name ' CreateInfoTip ' ,
ShowInfoTip name ' ShowInfoTip ' ,
DestroyInfoTip name ' DestroyInfoTip ' ;

end .

 

转载于:https://www.cnblogs.com/doorsky/archive/2009/12/28/1634603.html