一个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.