定时显示提示控件 TToolTip
转载过来的,文章出自:
http://www.delphifans.com/infoview/Article_3640.html
{
修改者:ghs
日期:20071218
功能:在原版本的基础上增加。
RegisterControl:注册需要提示的控件。
BeginHelp:设置光标状态为帮助crHelp;
鼠标弹起后,显示注册的提示信息,同时光标进行还原。
原版本
作者:thaoqi
出处:http://www.2ccc.com/article.asp?articleid=4389
功能:首先谢谢xsherry大大,来盒子很长一段时间了,老是下东西,没有为盒子做什么贡献。
前段时间xsherry大大抛砖引玉的文章,给我启发很大,最近一个项目提出要求人
机交互界面更加有好,尽量少用MessageBox,所以在他的基础上,我试图模仿XP
登录时候的那个ToolTip提示功能,用API摸索出一个符合要求的ToolTip提示框出
来,最后我把实现的函数封装成了一个VCL的控件,希望大家能多提意见!
}
代码 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.
调用一:
if edt3.Text='' then
begin
tltp1.Popup(TWinControl(edt3).Handle, ttStopIcon,'提示','请输入产地');
Exit;
end;
调用二:
ToolTip1.RegisterControl(LabeledEdit1, '提示', '请输入用户名');
ToolTip1.BeginHelp;
http://www.cnblogs.com/kfarvid/archive/2010/08/02/1790603.html
定时显示提示控件 TToolTip的更多相关文章
- 重新想象 Windows 8 Store Apps (4) - 控件之提示控件: ProgressRing; 范围控件: ProgressBar, Slider
原文:重新想象 Windows 8 Store Apps (4) - 控件之提示控件: ProgressRing; 范围控件: ProgressBar, Slider [源码下载] 重新想象 Wind ...
- jquery的智能提示控件
福利到~分享一个基于jquery的智能提示控件intellSeach.js 一.需求 我们经常会遇到[站内搜索]的需求,为了提高用户体验,我们希望能做到像百度那样的即时智能提示.例如:某公司人事管 ...
- 显示列表控件(引用SourceGrid)
using System; using System.Collections.Generic; using System.ComponentModel; using System.Drawing; u ...
- WPF通过不透明蒙板切割显示子控件
版权声明:本文为博主原创文章,遵循 CC 4.0 BY-SA 版权协议,转载请附上原文出处链接和本声明.本文链接:https://blog.csdn.net/Backspace110/article/ ...
- 错误提示控件errorProvider
http://www.cnblogs.com/suguoqiang/archive/2012/07/17/2596564.html 错误提示控件errorProvider VS显示: 核心代码: th ...
- Winform开发框架之肖像显示保存控件的实现
我们在开发一些Winform程序的时候,除了常规的显示普通数据外,有的时候需要显示一些人员肖像或者一些车辆等物体的图片,一般这些内容较小,所以以二进制存储在数据库是一个不错的方案.但由于它们虽然很常用 ...
- 【转】silverlight telerik RadGridView 列头显示其他控件
<telerik:GridViewDataColumn DataMemberBinding="{Binding target_id}" IsFilterable=" ...
- jquery messagetip信息语提示控件
编写原因: 作为提示框,jquery有个messagebox的控件,也就是弹出的提示框.但这个控件如果不是用在需要确认的时候,单单警告提示.消息提示.失败提示时,用户还需要去点下确认,有时这操作还是挺 ...
- 气泡形提示控件grumble.js
grumble.js 是一个很特别的气泡形状提示控件,最开始是为 Huddle.com 网站开发的, 它没有通常的north/east/south/west的定位限制. 任何一个grumble都可以放 ...
随机推荐
- Spring AOP (Spring 3.x 企业应用开发实战读书笔记第六章)
从面相对象编程到面相切面编程,是一种代码组织方式的进化. 每一代的代码组织方式,其实是为了解决当时面对的问题.比如写编译器和写操作系统的时候的年代当然要pop,比如写界面的时候当然要oop,因为界面这 ...
- android loadlibrary 更改libPath 路径,指定路径加载.so
http://www.jianshu.com/p/f751be55d1fb 字数549 阅读177 评论0 喜欢0 需求很简单 ,就是加载指定文件夹下的.so. 原因:android在程序运行的状态下 ...
- ubuntu系统安装flashplayer
打开浏览器,输入adobe flashplayer 进入官方网站,下载Linux 32-bit, 简体中文, Firefox,下载.tar.gz包. 然后点击立即下载.下载之后找到解压该文件夹,找到 ...
- Thread多线程stopSleep顺序问题
今天呢,学习了javase多线程,里面的睡眠sleep问题有点困扰: public class Thread_06_stopSleep{ public static void main(String[ ...
- (四)JAVA使用POI操作excel
1,字体处理 Demo12.java package com.wishwzp.poi; import java.io.FileOutputStream; import org.apache.poi.h ...
- ### 学习《C++ Primer》- 7
Part 7: 重载运算与类型转换(第14章) // @author: gr // @date: 2015-01-08 // @email: forgerui@gmail.com 一.重载运算符要求 ...
- vmware以及schlumberger题解
先是vmare的:具体的题目我就不描述了. 1. 贪吃的小明.直接数个数,统计个数,就可以完成.使用map,应该输入implement这一类,我认为很简单,但是我只过了33%. /* ID: y119 ...
- C++对象模型与内存位对齐的简单分析(GNU GCC&VS2015编译器)
以Fruit和Apple为例进行分析: Fruit和Apple的定义如下: 通过在两种编译环境下的测试(GNU GCC & VS2015),可以发现这两种编译器的对象模型是一样的,如下图所示: ...
- MFC通过ADO操作Access数据库
我在<VC知识库在线杂志>第十四期和第十五期上曾发表了两篇文章——“直接通过ODBC读.写Excel表格文件”和“直接通过DAO读.写Access文件”,先后给大家介绍了ODBC和DAO两 ...
- 关于MessageBox的用法
今天编写MFC工程的时候,使用MessageBox函数,老是出错,不断从网上查找解决方案,最后找到了 MessageBox( _T("Help, Something went wrong.& ...