弹出式气泡，使用winAPI

unit Ut_BalloonHint;
interface
uses
  Windows, Messages,Graphics, SysUtils,  StdCtrls,Commctrl;
const
 TTS_BALLOON    = $40;
 TTM_SETTITLE = (WM_USER + 32);
type
  TBalloonHint = class(TObject)
    private
       hTooltip: Cardinal;      //气球窗口句柄
       hExternal : THandle;     //外部控件句柄（如按钮等）
       buffer : array[0..255] of char; //存放提示信息
       ti: TToolInfo;
       //BackColor,TextColor分别是背景颜色和文本颜色,如果是0则取默认值.
       procedure AddToolTip(hwnd: dword; lpti: PToolInfo; IconType: Integer; Text, Title: PChar; BackColor,TextColor:TColor);
    public
       constructor Create(hWnd: Cardinal);
       procedure ShowMsg(conType: Integer; msg,msgTitle: String; BackColor :TColor = 0; TextColor:TColor =0);
  end;
implementation

//==============实现飞跃提示——包括提示的标题、内容、图标等项目========================
procedure TBalloonHint.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;
//==============气泡构造函数========================
constructor TBalloonHint.Create(hWnd: Cardinal);
begin
   hExternal := hWnd;
   // CreateWindowEx  创建一个具有扩展风格的子窗口
   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, 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;
end;

//==============显示气泡提示========================
procedure TBalloonHint.ShowMsg(conType: Integer; msg,msgTitle: String; BackColor, TextColor: TColor);
begin
    AddToolTip(hExternal, @ti, conType, PChar(Msg), PChar(msgTitle) ,BackColor,TextColor);
end;
end.

---------------------------------------------------------------------------------------------------------------------------------------

页面2 ：

unit test;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Ut_BalloonHint, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//==================无图标的飞跃提示==================
procedure TForm1.Button1Click(Sender: TObject);
var
   h :TBalloonHint;
begin
   h := TBalloonHint.Create(Button1.Handle);
   h.ShowMsg(0,'气泡提示','');
   h.Free;
end;

//==================蓝色信息提示图标的飞跃提示==================
procedure TForm1.Button2Click(Sender: TObject);
var
   h :TBalloonHint;
begin
   h := TBalloonHint.Create(Button2.Handle);
   h.ShowMsg(1,'气泡提示','信息图标');
   h.Free;
end;
//==================黄色警告图标的飞跃提示==================
procedure TForm1.Button3Click(Sender: TObject);
var
   h :TBalloonHint;
begin
   h := TBalloonHint.Create(Button3.Handle);
   h.ShowMsg(2,'气泡提示','警告图标');
   h.Free;
end;

//==================红色错误图标的飞跃提示==================
procedure TForm1.Button4Click(Sender: TObject);
var
   h :TBalloonHint;
begin
   h := TBalloonHint.Create(Button4.Handle);
   h.ShowMsg(3,'气泡提示','错误图标');
   h.Free;
end;

end.