气泡提示比弹出框可能用户体验更好,下面是从网上搜索来的代码
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,commctrl, StdCtrls, Buttons;
type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
Edit1: TEdit;
cbb1: TComboBox;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure CreateBox(h: HWND; text, cap : string; IconType: Integer = 1; T: Integer = 1000);
var
r : TRect;
hTooltip: Cardinal;
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,'控件' + cbb1.Text,'你好');
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.