发掘ListBox的潜力（三）：显示即时提示（Tips）

最新推荐文章于 2022-10-02 09:03:29 发布

nhconch

最新推荐文章于 2022-10-02 09:03:29 发布

阅读量4.8k

点赞数

分类专栏： Dephi&BCB 文章标签： integer destructor constructor string tts class

本文链接：https://blog.csdn.net/nhconch/article/details/520164

版权

Dephi&BCB 专栏收录该内容

57 篇文章 0 订阅

订阅专栏

ListBox显示即时提示（Tips）

　　Listbox内容太长时超出Listbox宽度的部分将无法显示，一种解决方法是让Listbox产生横向滚动条，滚动显示内容（见前面的《发掘ListBox的潜力（一）：自动调整横向滚动条宽度》），另一种方法是让Listbox以Tips的方法显示完整内容。本文要实现的是后一种方式。

　　Tips其实是一个特殊的窗体，类名为：tooltips_class32（在Commctrl(D6)有定义），可使用CreateWindow函数创建；Windows定义了一组以TTM_开头的消息用来与之通信，比如设置显示内容使用TTM_SETTITLE、删除显示内容使用TTM_DELTOOL。下面是例子：

hWndTip := CreateWindow(TOOLTIPS_CLASS, 'kktListBoxToolTips',
WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP, 0, 0, 0, 0, hWndTip, 0, HInstance, nil);
SendMessage(hWndTip, TTM_ADDTOOL, 0, Integer(@ti));
SendMessage(hWndTip, TTM_DELTOOL, 0, Integer(@ti));

Tips有两种显示时机：鼠标指向某ListItem时和鼠标点击某ListItem时，这里提供了一个选项供用户，默认为鼠标点击ListItem时显示，因此在type作如下声明：

TToolTipShowEvent = (tsMouseOver, tsClick);

并在控件published处声明ShowToolTipWhen属性：

property ShowToolTipWhen: TToolTipShowEvent read FShowToolTipWhen write SetShowToolTipWhen default tsClick;

接下来处理WM_LBUTTONDOWN消息判断是否应该显示内容，及处理要显示的内容：

procedure TkktListBox.WMMouseLBDown(var Message: TMessage);
var
X, Y, i: integer;
begin
inherited;
if (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;

对WM_MOUSEMOVE的处理方式类似：

procedure TkktListBox.WMMouseMove(var Message: TMessage);
var
X, Y, i: integer;
begin
if (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;

Tips的消隐则在CM_MOUSELEAVE消息里处理：

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

下面给出TkktListBox的完整代码：

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.