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.
- 大小: 13.7 KB
分享到:
相关推荐
delphi 6 气泡提示 hTrayIcon 控件
Delphi气泡提示源码例子,实现类似Windows右下角一样的气泡提示,实用的程序提示效果,无控件,虽然不完美,但用原生Delphi代码写出这种气泡也相当牛啊,不是吗?
Delphi代码演示TTrayIcon控件的使用方法,带气泡提示的托盘图标,后键可退出程序,系统消息 处理最小化的时候 应该隐藏主窗体 同时显示托盘图标,互斥,就是你有我没有你没有我就有,设置的每5s弹出气泡和闪烁提醒。
气泡式的控件,很有用
一个Delphi文档资料管理器源代码,界面使用了WSkinData控件进行美化,添加了气泡提示和自定义热键功能,程序可对文档一类的资料进行管理,可作为自己的一个经典文章收藏程序。
Delphi 记事提醒簿源程序,功能 比较多,用到有控件。 可以按日期提醒、按月提醒、提醒周期、提醒方式(气泡、声音),可以设置是否随Windows启动等,在系统托盘显示图标和主菜单,适合学习的Delphi的朋友参考...
很不错,拿来就可以用
看注释:功能很简单,服务端结合TTrayIcon控件使用,接收消息作为气泡弹出,关闭指令'Quit'
非常好的一个实例,把网络连接的UDP/TCP都插入到CList控件中显示出来。 VC++视频捕捉系统 win32下 视频操作。 VC++视频会议系统(完整)有开发文档。使用了系统自带的视频。 Windows核心编程(第五版)随书源代码 ...
非常好的一个实例,把网络连接的UDP/TCP都插入到CList控件中显示出来。 VC++视频捕捉系统 win32下 视频操作。 VC++视频会议系统(完整)有开发文档。使用了系统自带的视频。 Windows核心编程(第五版)随书源代码 ...
VC++卡通风格气泡提示源码 VC++实现任务管理器源码 任务管理器应该大家都很熟悉,论坛里也有好多的任务管理器的源码,解决CListCtr刷新时滚动条跳到开始处。 VC++实现网络连接查看器源码 非常好的一个实例,把网络...
VC++卡通风格气泡提示源码 VC++实现任务管理器源码 任务管理器应该大家都很熟悉,论坛里也有好多的任务管理器的源码,解决CListCtr刷新时滚动条跳到开始处。 VC++实现网络连接查看器源码 非常好的一个实例,把网络...
VC++卡通风格气泡提示源码 VC++实现任务管理器源码 任务管理器应该大家都很熟悉,论坛里也有好多的任务管理器的源码,解决CListCtr刷新时滚动条跳到开始处。 VC++实现网络连接查看器源码 非常好的一个实例,把网络...
SUIPack是一款为Delphi和C++Builder开发的所见即所得的界面增强VCL组件,它可以帮助您创建具有专业的界面外观设计的应用程序,大大节省您的时间和开发成本。 SUIPack 提供超过60个组件。只要将它们放置在一个form...
自己做的截图软件,可以全屏和部分屏截图,除了用了热键管理的第三方控件,其他像气泡等都是用DELPHI自带的控件实现,这是我的学习DELPHI的初始之作,有问题请联系我,QQ:260086501
内含各种例子(vc下各种控件的使用方法、标题栏与菜单栏、工具栏与状态栏、图标与光标、程序窗口、程序控制、进程与线程、字符串、文件读写操作、文件与文件夹属性操作、文件与文件夹系统操作、系统控制操作、程序...