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;
![文章来自编程手札http://blog.csdn.net/nhocnch,您现在所见为非法转载!](https://p-blog.csdn.net/images/p_blog_csdn_net/nhconch/155442/o_pascr1.gif)
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;
![文章来自编程手札http://blog.csdn.net/nhconch,您现在所见为非法转载!!](https://p-blog.csdn.net/images/p_blog_csdn_net/nhconch/155442/o_pascr2.gif)
//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 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); 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. |