unit kktListBox;
interface

uses
  Windows, Messages, SysUtils, Classes, Controls, StdCtrls, Commctrl;

const
  TTM_SETTITLE = (WM_USER + 32);

type
  TGetHintTextEvent = procedure(Index: integer; var HintText: string; Sender: TObject) of object;
  TToolTipShowEvent = (tsMouseOver, tsClick);

  TkktListBox = class(TListBox)
private

    hWndTip: THandle;
    ti: TOOLINFO;

    TipsIndex: integer;

    FOnGetHintText: TGetHintTextEvent;

    FHintTitle: String;

    FShowToolTipWhen: TToolTipShowEvent;

    procedure SetHintText(Index: integer);
procedure SetHintTitle(const Value: String);
procedure SetShowToolTipWhen(const Value: TToolTipShowEvent);

  protected
    property ScrollWidth stored False;
public

constructor Create(AOwner: TComponent); override;
procedure CreateWnd; override;
destructor Destroy; override;

  published
    property HintTitle: String read FHintTitle write SetHintTitle;
property ShowToolTipWhen: TToolTipShowEvent read FShowToolTipWhen write SetShowToolTipWhen default tsClick;
property OnGetHintText: TGetHintTextEvent Read FOnGetHintText write FOnGetHintText;

  end;

procedure Register;

implementation

{ TkktListBox }

procedure TkktListBox.CMMouseLeave(var Message: TMessage);
begin
  inherited;

  HideToolTip;
end;

constructor TkktListBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  TipsIndex := -1;

  FShowToolTipWhen := tsClick;
end;

    //uId := Handle;

    hinst := hInstance;

    lpszText := nil;
//LPSTR_TEXTCALLBACK;
    //CALLBACK将导致回调次数太多
     Rect.Left := 0;

    Rect.Top := 0;

    Rect.Bottom := 0;

    Rect.Right := 0;
end;

  sendMessage(hWndTip, WM_SETFONT, Self.Font.Handle, Integer(LongBool(False)));

  SendMessage(hWndTip, TTM_ADDTOOL, 0, Integer(@ti));

  SendMessage(hWndTip, TTM_SETTITLE, 0, Integer(Pchar(FHintTitle)));
end;

destructor TkktListBox.Destroy;
begin
  if hWndTip<>0 then SendMessage(hWndTip, WM_CLOSE, 0, 0);
inherited;
end;

procedure TkktListBox.HideToolTip;
begin
  TipsIndex := -1;

  SendMessage(hWndTip, TTM_TRACKACTIVATE, 0, 0);
end;

procedure TkktListBox.ShowToolTip(X, Y, Index: integer);
var
  APoint: TPoint;

  ARect: TRect;
begin
  if (FShowToolTipWhen = tsClick) and (Index = TipsIndex) then Exit;

  if FShowToolTipWhen = tsMouseOver then begin
    APoint := Point(X+20, Y+20);
end else begin    //FShowToolTipWhen = tsClick
    ARect := ItemRect(Index);

    APoint := ARect.TopLeft;
end;

  APoint := Self.ClientToScreen(APoint);

  SendMessage(hWndTip, TTM_TRACKPOSITION, 0, MAKELPARAM(APoint.X, APoint.Y));
if Index = TipsIndex then Exit;

  SetHintText(Index);

  SendMessage(hWndTip, TTM_TRACKACTIVATE, 1, integer(@ti));

  TipsIndex := Index;
end;

procedure TkktListBox.WMMouseLBDown(var Message: TMessage);
var
  X, Y, i: integer;
begin
  inherited;
if (csDesigning in ComponentState) or (FShowToolTipWhen = tsMouseOver) then Exit;

  X := LOWORD(Message.lParam);

  Y := HIWORD(Message.lParam);

  i := ItemAtPos(Point(X, Y), true);    //ItemIndex
  if (i = -1) and (TipsIndex <> -1) then HideToolTip;
if i<>-1 then ShowToolTip(X, Y, i);
end;

procedure TkktListBox.WMMouseMove(var Message: TMessage);
var
  X, Y, i: integer;
begin
  if (csDesigning in ComponentState) or (FShowToolTipWhen = tsClick) then Exit;

  X := LOWORD(Message.lParam);

  Y := HIWORD(Message.lParam);

  i := ItemAtPos(Point(X, Y), true);
if (i = -1) and (TipsIndex <> -1) then HideToolTip;
if i<>-1 then ShowToolTip(X, Y, i);
inherited;
end;

procedure TkktListBox.SetHintTitle(const Value: String);
begin
  if FHintTitle = Value then Exit;

  FHintTitle := Value;

  SendMessage(hWndTip, TTM_SETTITLE, 0, Integer(Pchar(FHintTitle)));
end;

procedure TkktListBox.SetHintText(Index: integer);
var
  HintText: string;
begin
  if Index<0 then Exit;

  SendMessage(hWndTip, TTM_DELTOOL, 0, Integer(@ti));

  HideToolTip;

  HintText := Items[Index];
if Assigned(FOnGetHintText) then FOnGetHintText(Index, HintText, Self);

  ti.lpszText := @HintText[1];

  SendMessage(hWndTip, TTM_ADDTOOL, 0, Integer(@ti));
end;

procedure TkktListBox.SetShowToolTipWhen(const Value: TToolTipShowEvent);
begin
  if FShowToolTipWhen <> Value then begin
    FShowToolTipWhen := Value;

    HideToolTip;
end;
end;

procedure Register;
begin
  RegisterComponents('Kacarton', [TkktListBox]);
end;

end.