delphi 气泡提示相关代码.

D1

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellApi, StdCtrls, Menus;
const
WM_POP_MESSAGE = WM_USER + 1; //自定义消息 MSN提示窗口...
WM_ICONTRAY = WM_USER + 2; //自定义消息 托盘图标
NIF_INFO = $10;
NIF_MESSAGE = 1;
NIF_ICON = 2;
NOTIFYICON_VERSION = 3;
NIF_TIP = 4;
NIM_SETVERSION = $00000004;
NIM_SETFOCUS = $00000003;
NIIF_INFO = $00000001;
NIIF_WARNING = $00000002;
NIIF_ERROR = $00000003;
type
TDUMMYUNIONNAME = record
case Integer of
0: (uTimeout: UINT);
1: (uVersion: UINT);
end;
TNotifyIconData = record
cbSize: DWORD;
Wnd: HWND;
uID: UINT;
uFlags: UINT;
uCallbackMessage: UINT;
hIcon: HICON;
szTip: array[0..127] of Char;
dwState: DWORD;
dwStateMask: DWORD;
szInfo: array[0..255] of Char;
DUMMYUNIONNAME: TDUMMYUNIONNAME;
szInfoTitle: array[0..63] of Char;
dwInfoFlags: DWORD;
end;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
PopupMenu1: TPopupMenu;
yh1: TMenuItem;
N87pokjpo1: TMenuItem;
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure TrayMessage(var Msg: TMessage); message WM_ICONTRAY;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
icondata: tnotifyicondata;
TrayIconData: tnotifyicondata;
implementation
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject); //添加托盘区图标
var
mytitle, mytext: string;
begin
TrayIconData.cbSize := SizeOf(TrayIconData);
TrayIconData.uFlags := $10;
mytext := '内容， 8658587^_^';
strPLCopy(TrayIconData.szInfo, mytext, SizeOf(TrayIconData.szInfo) - 1);
// TrayIconData.DUMMYUNIONNAME.uTimeout := 300; //停留时间
mytitle := 'jin 标题';
strPLCopy(TrayIconData.szInfoTitle, mytitle, SizeOf(TrayIconData.szInfoTitle) - 1);
TrayIconData.dwInfoFlags := NIIF_INFO; //图标类型
Shell_NotifyIcon(NIM_MODIFY, @TrayIconData);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
with TrayIconData do
begin
cbSize := SizeOf(TrayIconData);
Wnd := Handle;
uID := 0;
uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP;
uCallbackMessage := WM_ICONTRAY;
hIcon := Application.Icon.Handle;
szTip := '提示信息！';
end;
Shell_NotifyIcon(NIM_ADD, @TrayIconData);
end;
procedure TForm1.TrayMessage(var Msg: TMessage);
var
p: TPoint;
begin
case Msg.lParam of
WM_LBUTTONDOWN: //左键
begin
ShowMessage('你在图标上面单击了左键');
// MostrarOcultar1.Click;
end;
WM_RBUTTONDOWN: //右键
begin
SetForegroundWindow(form1.Handle);
GetCursorPos(p);
PopUpMenu1.Popup(p.x, p.y);
PostMessage(form1.Handle, WM_NULL, 0, 0);
end;
end;
end;
proce

dure TForm1.Button1Click(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @TrayIconData); //删除托盘区图标
end;
end.
///////////////////////////////////////////////////////////////////////////////////////////////////
非托盘区气球提示：
uses
Commctrl;
procedure ShowBalloonTip(Control: TWinControl; Icon: integer; Title: pchar; Text: PWideChar;
BackCL, TextCL: TColor);
const
TOOLTIPS_CLASS = 'tooltips_class32';
TTS_ALWAYSTIP = $01;
TTS_NOPREFIX = $02;
TTS_BALLOON = $40;
TTF_SUBCLASS = $0010;
TTF_TRANSPARENT = $0100;
TTF_CENTERTIP = $0002;
TTM_ADDTOOL = $0400 + 50;
TTM_SETTITLE = (WM_USER + 32);
ICC_WIN95_CLASSES = $000000FF;
type
TOOLINFO = packed record
cbSize: Integer;
uFlags: Integer;
hwnd: THandle;
uId: Integer;
rect: TRect;
hinst: THandle;
lpszText: PWideChar;
lParam: Integer;
end;
var
hWndTip: THandle;
ti: TOOLINFO;
hWnd: THandle;
begin
hWnd := Control.Handle;
hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
0, 0, 0, 0, hWnd, 0, HInstance, nil);
if hWndTip <> 0 then
begin
SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
ti.cbSize := SizeOf(ti);
ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_SUBCLASS;
ti.hwnd := hWnd;
ti.lpszText := Text;
Windows.GetClientRect(hWnd, ti.rect);
SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0);
SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0);
SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
end;
end;
{效果演示}
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowBalloonTip(Button1, 1, '标题', '我在这里！', clBlue, clNavy);
end;

2
Delphi 三种气泡提示效果
2011-03-19 14:55
一、方法一
说明：这个效果不好，鼠标必须放在按钮上，气泡提示才可以出来，如果鼠标在按钮的范围之外，
用回车键点击按钮也不会激活气泡提示。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,CommCtrl;
const
TTS_BALLOON = $40;
TTM_SETTITLE = (WM_USER + 32);
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
hTooltip: Cardinal;
ti: TToolInfo;
buffer : array[0..255] of char;
implementation
{$R *.dfm}
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, hI

nstance, 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;
end;
//BackColor,TextColor分别是背景颜色和文本颜色,如果是0则取默认值.
procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title: PChar;
BackColor,TextColor:TColor);
var
Rect: TRect;
begin
if (hwnd <> 0) AND (GetClientRect(hwnd, Rect)) then
begin
lpti.hwnd := hwnd;
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;
if BackColor <> 0 then
SendMessage(hToolTip, TTM_SETTIPBKCOLOR, BackColor, 0);
if TextColor <> 0 then
SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, TextColor, 0);
SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateToolTips(Button1.Handle);
AddToolTip(Button1.Handle, @ti, 1, '提示内容', '提示标题',0,0); //数字1可以该为其它的数字来显示不同的图标
end;


----------------------------------------------------------------------------------------------------------------------------------------------------------------
一、方法二
效果图片如下：
说明：这个方法比较好，鼠标不必放在按钮上，只要按钮有焦点，用回车和空格键都可以出现气泡提示，
而且气泡提示是跟着鼠标的，也就是说鼠标移动到什么地方气泡提示也会出现在那里！
//代码如下：
//说明：这个是封装的一个类，调用的时候需要创建一个实例后，再调用那个方法即可。
1、类的代码：
unit uHintWin;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,CommCtrl;
type
THintWin = class(THintWindow)
private
FLastActive: THandle;
public
procedure ActivateHint(Rect:TRect;Const AHint:string);override;
end;
implementation

{ THintWin }
procedure AddTipTool(hWnd: DWORD; IconType: Integer; Title, Text: PChar);
const
TTS_BALLOON =$0040 ; //ToolTip提示窗口的外形，指定为气球型
TTM_SETTITLE=WM_USER + 32; //设置提示标题信息的消息
var
hWndTip: DWORD;
ToolInfo: TToolInfo;
begin
hWndTip:=CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP ,

0, 0, 0, 0, hWnd, 0, HInstance, nil);
if (hWndTip <> 0) then
begin
ToolInfo.cbSize:=SizeOf(ToolInfo); //设置ToolInfo的大小
ToolInfo.uFlags:=TTF_IDISHWND or TTF_SUBCLASS or TTF_TRANSPARENT; //设置基本风格
ToolInfo.uId:=hWnd; //设置所有者的句柄
ToolInfo.lpszText:=Text;
SendMessage(hWndTip,TTM_ADDTOOL,1,Integer(@ToolInfo));
SendMessage(hWndTip,TTM_SETTITLE,2,Integer(Title)); //设置气泡窗体的提示图标和标题信息
SendMessage(hWndTip, TTM_SETTIPBKCOLOR, $D2FAFA, 0); //设置背景色
SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, $4040 , 0); //设置字体颜色
end;
InitCommonControls();
end;
procedure THintWin.ActivateHint(Rect: TRect; const AHint: string);
begin
inherited;
if FLastActive <> WindowFromPoint(Mouse.CursorPos) then
AddTipTool(WindowFromPoint(Mouse.CursorPos),1,'Sherry SoftWare', PChar(AHint));//Application.Hint));
FLastActive:=WindowFromPoint(Mouse.CursorPos);
end;
initialization
Application.HintPause:=0;
Application.ShowHint:=False;
HintWindowClass:=THintWin;
Application.ShowHint:=True;
end.
2、调用的代码
//说明：调用之前要引用上面这个类的单元。
procedure TForm2.Button1Click(Sender: TObject);
var
a:THintWin;
Rect: TRect;
begin
a := THintWin.Create(Self);
a.ActivateHint(Rect,'测试提示气泡！');
sndPlaySound('C:\Windows\Media\Windows XP 气球.wav', SND_ASYNC );
end;


----------------------------------------------------------------------------------------------------------------------------------------------------------------
一、方法三
在任意控件里显示气泡，不需要鼠标放在控件上才显示。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,commctrl, StdCtrls, Buttons;
type
TForm1 = class(TForm)
Button1: TButton;
cbb1: TComboBox;
edt1: TEdit;
lst1: TListBox;
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure CreateBox(h:HWND;text,cap:string;IconType:integer=1;t:integer=1000);
var
r : TRect; //是一个记录（Record），保存了矩形的（左上角右下角两个点）4个坐标或2个点的值。
hTooltip: Cardinal; //Cardinal是无符号32位整数 ，取值0到4294967295范围。
ti: TToolInfo;
begin
hToolTip := CreateWindow('Tooltips_Class32',nil,$40,0,0,0,0,0,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_IDISHWND or TTF_TRACK;
ti.hInst := hInstance;
ti.lpszText :=pchar(text);
SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(@ti));
if (IconType > 3) or (IconType < 0) then IconType:=0;
SendMessage(hToolTip,WM_USER + 32,IconType,Integer(pchar(cap)));
GetWindowRect(H,R); //获取指定控件的坐标,R.Right 、R.Left、R.Bottom、R.Top
SendMessage(hToolTip,TTM_TRACKPOSITION, 0, MAKELONG((r.Right - r.Left) div 2 + r.Left, (r.Bottom - r.Top) div 2 + r.Top)); // 定义气泡位置
SendMessage(hToolTip, TTM_TRACKACTIVATE, Integer(True), Integer(@ti));
Sleep(t);
DestroyWindow(hToolTip);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateBox(TButton(form1.FindComponent(cbb1.Text)).Handle,'处理群内陌生人问题','你好');
end;
procedure TForm1.FormActivate(Sender: TObject);
var i:integer;
begin
for i:=0 to ComponentCount-1 do //得到窗体的所有控件。
cbb1.Items.Add(Components[i].Name);
cbb1.ItemIndex:=0;//设置选中第一项。
end;
end.



----------------------------------------------------------------------------------------------------------------------------------------------------------------
WM_USER = $400;
TTN_FIRST = 0-520;
TTS_ALWAYSTIP = $01;
TTS_NOPREFIX = $02;
TTF_IDISHWND = $01;
TTF_CENTERTIP = $02;
TTF_RTLREADING = $04;
TTF_SUBCLASS = $10;
TTS_NOANIMATE = $10;
TTS_NOFADE = $20;
TTS_BALLOON = $40;
TTF_TRACK = $00000020;
TTF_ABSOLUTE = $00000080;
TTF_TRANSPARENT = $00000100;
TTI_NONE = $0;
TTI_INFO = $1;
TTI_WARNING = $2;
TTI_ERROR = $3;
TTM_TRACKACTIVATE = WM_USER + 17;
TTM_TRACKPOSITION = WM_USER + 18;
TTM_SETTIPBKCOLOR = WM_USER + 19;
TTM_SETTIPTEXTCOLOR = WM_USER + 20;
TTM_GETDELAYTIME = WM_USER + 21;
TTM_GETTIPBKCOLOR = WM_USER + 22;
TTM_GETTIPTEXTCOLOR = WM_USER + 23;
TTM_SETMAXTIPWIDTH = WM_USER + 24;
TTM_GETMAXTIPWIDTH = WM_USER + 25;
TTM_SETMARGIN = WM_USER + 26;
TTM_GETMARGIN = WM_USER + 27;
TTM_POP = WM_USER + 28;
TTM_GETBUBBLESIZE = WM_USER + 30;
TTM_ADJUSTRECT = WM_USER + 31;
TTM_SETTITLE = WM_USER + 32;
TTM_SETTITLEW = WM_USER + 33;
TTN_GETDISPINFOW = (TTN_FIRST - 10);
TOOLTIPS_CLASS = 'tooltips_class32'


3js

您知道吗？

>，




4一个DELPHI下的气泡提示控件

unit PPTip;
interface
uses
SysUtils, Windows, Messages, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,CommCtrl,ExtCtrls;
type
TPPTip = class(TComponent)
private
timer : TTimer; //显示延时器
FlashTimer:TTimer;
AControl:TWinControl;
FlashShape:TShape;
fTipHandle: HWND;//泡泡提示窗口句柄
protected
FInterval:Integer; //延时毫秒数
ColorTag : Integer; //颜色开关
procedure setFInterval(AInterval:Integer);
procedure CloseTip(Sender:TObject);
procedure onFlashTimer(Sender:TObject);
public
constructor Create(Owener:TComponent);override;
destructor Destroy;override;
procedure PopTip(sText: string;AOwner: TWinControl;nIcon: Integer=0;
timeout: Integer = 5;sTitle: string = '');
published
property Interval:Integer read FInterval write setFInterval;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TPPTip]);
end;
procedure TPPTip.PopTip(
sText: string; // 提示框文本
AOwner: TWinControl; // 提示框坐标
nIcon: Integer = 0; // 提示框图标 0: 默认 1: 提示 2: 感叹号 3: 错误
timeout: Integer = 5; //提示框消失时间
sTitle: string = ''); //提示框标题 默认为application.title
const
TTS_BALLOON = $0040; //ToolTip提示窗口的外形，指定为气球型
TTS_CLOSE = $0080;
//关闭按钮(仅XP及以上版本弄够支持） (PS:郁闷 , 我的电脑上怎么就不出现这个按钮呢?)
TTF_PARSELINKS = $1000; //可使用超链接
TTM_SETTITLE = WM_USER + 32; //设置提示标题信息的消息
var
i: Integer;
ftoolInfo: tagToolInfoA;
str: string;
vPoint: TPoint;
buffer:array[0..25] of char;
begin
if fTipHandle <> 0 then
begin
DestroyWindow(fTipHandle)
end;
fTipHandle := CreateWindow(TOOLTIPS_CLASS, nil,
WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP or TTS_CLOSE,
0, 0, 0, 0, Application.Handle,
0, HInstance, nil);
if fTipHandle = 0 then Exit;
fToolInfo.cbSize := SizeOf(fToolInfo); //设置ToolInfo的大小
fToolInfo.uFlags := TTF_PARSELINKS or TTF_IDISHWND or TTF_TRACK; //设置基本风格
fToolInfo.uId := Application.Handle; //设置所有者的句柄
fToolInfo.lpszText := PAnsiChar(sText); //设置标题信息
//向气泡窗体发送消息，将ToolInfo的信息设置到气泡窗体中
FillChar(buffer,SizeOf(buffer),#0);
lstrcpy(buffer,'错误');
SendMessage(fTipHandle, $0400 + 32, nIcon, Integer(@buffer));
SendMessage(fTipHandle, TTM_ADDTOOL, 0, Integer(@fToolInfo));
SendMessage(fTipHandle, TTM_SETTOOLINFO, 0, Integer(@fToolInfo));
SendMessage(fTipHandle, TTM_SETTIPBKCOLOR, clWhite, 0); //设置背景色
SendMessage(fTipHandle, TTM_SETTIPTEXTCOLOR, clGreen , 0); //设置字体颜色
//设置气泡窗体的提示

图标和标题信息 ,{图标消息发送不成功.不知道应该是哪个消息}
str := sTitle;
if str = '' then str := Application.Title;
SendMessage(fTipHandle, TTM_SETTITLE, 1, Integer(str));
//下面这两个初值要设置,害死人呢.ClientToScreen得到的坐标相当不准.
vPoint.X :=0;
vPoint.Y := 0;
windows.ClientToScreen(AOwner.Handle, vPoint);
vPoint.X := vPoint.X + AOwner.Width div 2 ;
vPoint.Y := vPoint.Y + AOwner.Height div 2 ;
SendMessage(fTipHandle, TTM_TRACKPOSITION, 0, MAKELONG(vPoint.x, vPoint.y));
//激活气泡窗体，并显示出来
PostMessage(fTipHandle, TTM_TRACKACTIVATE, Integer(True),Integer(@fToolInfo));
Application.ProcessMessages;
//光标跳转
if AOwner.CanFocus then AOwner.SetFocus;
//计时开始
timer.Enabled := True;
AControl := AOwner;
FlashTimer.Enabled := True;
end;

procedure TPPTip.CloseTip(Sender: TObject);
begin
timer.Enabled := false;
FlashTimer.Enabled := False;
FlashShape.Hide;
DestroyWindow(fTipHandle);
end;
constructor TPPTip.Create(Owener:TComponent);
begin
inherited Create(Owener);
timer := TTimer.Create(Self);
FlashTimer := TTimer.Create(self);
FlashShape := TShape.Create(self);
FlashShape.Brush.Style := bsClear;
Interval := 2000;
timer.Interval := Interval;
timer.Enabled := False;
timer.OnTimer := CloseTip;
FlashTimer.Interval := 100;
FlashTimer.Enabled := False;
FlashTimer.OnTimer := onFlashTimer;
end;
procedure TPPTip.setFInterval(AInterval: Integer);
begin
if AInterval < 100 then
AInterval := 30000;
FInterval := AInterval;
timer.Interval := FInterval;
end;
procedure TPPTip.onFlashTimer(Sender: TObject);
var
vPoint:TPoint;
begin
if Assigned(AControl) then
begin
ClientToScreen(Acontrol.Handle, vPoint);
FlashShape.left:= Acontrol.Left-1;
FlashShape.Top := Acontrol.top-1;
FlashShape.Width := AControl.Width+2;
FlashShape.Height := AControl.Height+2;
if ColorTag = 1 then
begin
FlashShape.Pen.Color := clRed;
FlashShape.Pen.Style := psDot;
ColorTag:=0;
end
else
begin
FlashShape.Pen.Color := clWhite;
FlashShape.Pen.Style := psDot ;
ColorTag := 1;
end;
FlashShape.Parent := AControl.Parent;
FlashShape.BringToFront;
FlashShape.Show;
FlashShape.Repaint;
end;
end;
destructor TPPTip.Destroy;
begin
if fTipHandle <> 0 then
begin
DestroyWindow(fTipHandle)
end;
inherited;
end;
end.