贴一个ToolTips（类似于Hint）

unit ToolTip;

interface

uses
  SysUtils, Classes, Graphics, Controls, Windows,
  CommCtrl;

type
  TIconType = (titNONE, titINFO, titWARNING, titERROR,
    titINFOLARGE, titWARNINGLARGE, titERRORLARGE);

  TToolTip = class(TControl)
  private
    FOwnerWnd: HWND;
    FHandle: HWND;
    FTitle: string;
    FText: string;
    FHoldSecond: Integer;
    FToolInfo: TToolInfo;
    procedure SetTitle(const Value: string);
    procedure SetText(const Value: string);
    procedure CalcOwnerWnd;
    procedure CreateToolTip;
    procedure InitToolTipInfo;
    procedure InitToolTip;
    function GetReshowTime: Integer;
    procedure SetReshowTime(const Value: Integer);
    function GetBackgroundColor: TColor;
    procedure SetBackgroundColor(const Value: TColor);
    function GetTextColor: TColor;
    procedure SetTextColor(const Value: TColor);
    function GetInitTime: Integer;
    procedure SetInitTime(const Value: Integer);
    function GetRemainTime: Integer;
    procedure SetRemainTime(const Value: Integer);
    function GetBound: TRect;
    procedure SetBound(const Value: TRect);
    function GetIconType: TIconType;
    procedure SetIconType(const Value: TIconType);
  protected
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;

    procedure ShowTip;
    property Bound: TRect read GetBound write SetBound;
  published
    property Title: string read FTitle write SetTitle;
    property Text: string read FText write SetText;
    property HoldSecond: Integer read FHoldSecond;
    property ReshowTime: Integer read GetReshowTime write SetReshowTime;
    property InitTime: Integer read GetInitTime write SetInitTime;
    property RemainTime: Integer read GetRemainTime write SetRemainTime;
    property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
    property TextColor: TColor read GetTextColor write SetTextColor;
    property IconType: TIconType read GetIconType write SetIconType;
  end;

procedure Register;

implementation
procedure Register;
begin
  RegisterComponents('Samples', [TToolTip]);
end;

{ TToolTip }

constructor TToolTip.Create(AOwner: TComponent);
begin
  inherited;
  CreateToolTip;
  InitToolTipInfo;
  InitToolTip;
end;

destructor TToolTip.Destroy;
begin
  DestroyWindow(FHandle);
  inherited;
end;

function TToolTip.GetBackgroundColor: TColor;
begin
  Result := SendMessage(FHandle, TTM_GETTIPBKCOLOR, 0, 0);
end;

function TToolTip.GetBound: TRect;
begin
end;

function TToolTip.GetIconType: TIconType;
begin
end;

function TToolTip.GetInitTime: Integer;
begin
  Result := SendMessage(FHandle, TTM_GETDELAYTIME, TTDT_INITIAL, 0);
end;

function TToolTip.GetRemainTime: Integer;
begin
  Result := SendMessage(FHandle, TTM_GETDELAYTIME, TTDT_AUTOPOP, 0);
end;

function TToolTip.GetReshowTime: Integer;
begin
  Result := SendMessage(FHandle, TTM_GETDELAYTIME, TTDT_RESHOW, 0);
end;

function TToolTip.GetTextColor: TColor;
begin
// Result := SendMessage(FHandle, TTM_GETTIPTEXTCOLOR, 0, 0);
end;

procedure TToolTip.InitToolTip;
begin
  SendMessage(FHandle, TTM_ADDTOOL, 0, Integer(@FToolInfo));
//  SendMessage(FHandle, TTM_SETTIPBKCOLOR, clWindow, 0);
//  SendMessage(FHandle, TTM_SETTIPTEXTCOLOR, clWindowText, 0);
end;

procedure TToolTip.InitToolTipInfo;
var
  Rect: TRect;
begin
  FToolInfo.cbSize := SizeOf(TToolInfo);
  FToolInfo.uFlags := TTF_SUBCLASS or TTF_TRANSPARENT;
  FToolInfo.hwnd := FOwnerWnd;
  Windows.GetClientRect(FOwnerWnd, Rect);
  FToolInfo.Rect := Rect;
  FToolInfo.hInst := HInstance;
  FToolInfo.lpszText := PChar(FText);
end;

procedure TToolTip.CreateToolTip;
begin
  FHandle := CreateWindowEx(0, 'Tooltips_Class32', nil,
    TTS_ALWAYSTIP or TTS_BALLOON or TTS_USEVISUALSTYLE ,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    FOwnerWnd, 0, HInstance, nil);
  SetWindowPos(FHandle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
end;

procedure TToolTip.SetBackgroundColor(const Value: TColor);
begin
  SendMessage(FHandle, TTM_SETTIPBKCOLOR, Value, 0)
end;

procedure TToolTip.SetBound(const Value: TRect);
begin
end;

procedure TToolTip.SetIconType(const Value: TIconType);
begin
  SendMessage(FHandle, TTM_SETTITLE, Ord(Value), Integer(PChar(FTitle)));
end;

procedure TToolTip.SetInitTime(const Value: Integer);
begin
  SendMessage(FHandle, TTM_SETDELAYTIME, TTDT_INITIAL, MAKELONG(Value, 0));
end;

procedure TToolTip.SetRemainTime(const Value: Integer);
begin
  SendMessage(FHandle, TTM_SETDELAYTIME, TTDT_AUTOPOP, MAKELONG(Value, 0));
end;

procedure TToolTip.SetReshowTime(const Value: Integer);
begin
  SendMessage(FHandle, TTM_SETDELAYTIME, TTDT_RESHOW, MAKELONG(Value, 0));
end;

procedure TToolTip.SetText(const Value: string);
begin
  FText := Value;
  FToolInfo.lpszText := PChar(FText);
  SendMessage(FHandle, TTM_UPDATETIPTEXT, 0, Integer(@FToolInfo));
end;

procedure TToolTip.SetTextColor(const Value: TColor);
begin
//  SendMessage(FHandle, TTM_SETTIPTEXTCOLOR, Value, 0);
//  SendMessage(FHandle, TTM_UPDATE, 0, 0);
end;

procedure TToolTip.SetTitle(const Value: string);
begin
  FTitle := Value;
  SendMessage(FHandle, TTM_SETTITLE, 0, Integer(PChar(FTitle)));
end;

procedure TToolTip.ShowTip;
begin
  SendMessage(FHandle, TTM_POPUP, 0, 0);
end;

end.