...Tooltips in einer TListBox anzeigen?

Autor: Happyjoe

Kategorie: VCL

{
  In-place ToolTips are used to display text strings for objects that have been clipped,
  in TreeView for example. The following code has been tested only on standard ListBox.
  Of cause you can use tips on other VCLs after appropriate modification.
  (Only copy following code to your form1's unit file)
}

//------------------------------------------------------------------------------
//  Show in-place tooltips on ListBox
//  Author£ºJoe Huang                 Email£ºHappyjoe@21cn.com
//
//------------------------------------------------------------------------------


unit Unit1;

interface

uses
  
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, CommCtrl;

type
  
//Override TListBox's WinProc to get CM_MOUSELEAVE message
  
TNewListBox = class(TListBox)
  protected
    
{ Protected declarations }
    
procedure WndProc(var Message: TMessage); override;
  end;

type
  
TForm1 = class(TForm)
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    
{ Private declarations }
    
GHWND: HWND;
    TipVisable: Boolean;
    OldIndex, CurrentIndex: Integer;
    ti: TOOLINFO;
    ListBox1: TListBox;

    procedure InitListBox;   //Create ListBox1 dynamically
    
procedure CreateTipsWindow;  //Create Tooltip Window
    
procedure HideTipsWindow;    //Hide Tooltip Window

    //WM_NOTIFY message's handler, fill Tooltip Window content
    
procedure WMNotify(var Msg: TMessage); message WM_NOTIFY;

    procedure ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  public
    
{ Public declarations }
  
end;

var
  
Form1: TForm1;

implementation

{$R *.dfm}

{ TNewListBox }

procedure TNewListBox.WndProc(var Message: TMessage);
begin
  case Message
.Msg of
    
CM_MOUSELEAVE: Form1.HideTipsWindow;
  end;
  inherited WndProc(Message);
end;

{ TForm1 }

procedure TForm1.InitListBox;
begin
  
ListBox1 := TNewListBox.Create(Self);
  ListBox1.Parent := Self;
  ListBox1.Left := 50;
  ListBox1.Top := 50;
  ListBox1.Width := 200;
  ListBox1.Height := 200;
  //append serveral items for testing
  
ListBox1.Items.Append('happyjoe');
  ListBox1.Items.Append('Please send me email: happyjoe@21cn.com');
  ListBox1.Items.Append('Delphi 5 Developer''s Guide');
  ListBox1.Items.Append('Delphi 5.X ADO/MTS/COM+ Advanced Development');

  ListBox1.OnMouseMove := ListBox_MouseMove;
  ListBox1.OnMouseDown := ListBox_MouseDown;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  
Self.Font.Name := 'Tahoma';
  InitListBox;
  CreateTipsWindow;
end;

procedure TForm1.CreateTipsWindow;
var
  
iccex: tagINITCOMMONCONTROLSEX;
begin
  
// Load the ToolTip class from the DLL.
  
iccex.dwSize := SizeOf(tagINITCOMMONCONTROLSEX);
  iccex.dwICC := ICC_BAR_CLASSES;
  InitCommonControlsEx(iccex);

  // Create the ToolTip control.
  
GHWND := CreateWindow(TOOLTIPS_CLASS, '',
                        WS_POPUP,
                        Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                        Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
                        0, 0, hInstance,
                        nil);

  // Prepare TOOLINFO structure for use as tracking ToolTip.
  
ti.cbSize := SizeOf(ti);
  ti.uFlags := TTF_IDISHWND + TTF_TRACK + TTF_ABSOLUTE + TTF_TRANSPARENT;
  ti.hwnd := Self.Handle;
  ti.uId := ListBox1.Handle;
  ti.hinst := hInstance;
  ti.lpszText := LPSTR_TEXTCALLBACK;
  ti.Rect.Left := 0;
  ti.Rect.Top := 0;
  ti.Rect.Bottom := 0;
  ti.Rect.Right := 0;

  SendMessage(GHWND, WM_SETFONT, ListBox1.Font.Handle, Integer(LongBool(False)));
  SendMessage(GHWND,TTM_ADDTOOL,0,Integer(@ti));
end;

procedure TForm1.WMNotify(var Msg: TMessage);
var
  
phd: PHDNotify;
  NMTTDISPINFO: PNMTTDispInfo;
begin
  
phd := PHDNotify(Msg.lParam);
  if phd.Hdr.hwndFrom = GHWND then
  begin
    if 
phd.Hdr.Code = TTN_NEEDTEXT then
    begin
      
NMTTDISPINFO := PNMTTDispInfo(phd);
      NMTTDISPINFO.lpszText := PChar(ListBox1.Items[CurrentIndex]);
    end;
  end;
end;

procedure TForm1.ListBox_MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if 
TipVisable then     //when mouse down, hide Tooltip Window
  
begin
    
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    TipVisable := False;
  end;
end;

procedure TForm1.ListBox_MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  
Index: Integer;
  APoint: TPoint;
  ARect: TRect;
  ScreenRect: TRect;
begin
  
Index := ListBox1.ItemAtPos(Point(X, Y), true);
  if Index = -1 then
  begin
    
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    OldIndex := -1;
    TipVisable := False;
    Exit;
  end;
  CurrentIndex := Index;
  if Index = OldIndex then Exit;
  if TipVisable then
  begin
    
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    OldIndex := -1;
    TipVisable := False;
  end else
  begin
    
ARect := ListBox1.ItemRect(Index);

    if (ARect.Right - ARect.Left - 2) >= ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) then
    begin
      
OldIndex := -1;
      Exit;
    end;
    APoint := ListBox1.ClientToScreen(ARect.TopLeft);
    windows.GetClientRect(GetDesktopWindow, ScreenRect);

    if ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) + APoint.X > ScreenRect.Right then
      
APoint.X := ScreenRect.Right - ListBox1.Canvas.TextWidth(ListBox1.Items[Index]) - 5;
    SendMessage(GHWND,
                TTM_TRACKPOSITION,
                0,
                MAKELPARAM(APoint.x - 1, APoint.y - 2));

    SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(True)), Integer(@ti));
    OldIndex := Index;
    TipVisable := True;
  end;
end;

procedure TForm1.HideTipsWindow;
begin
  if 
TipVisable then
  begin
    
SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
    OldIndex := -1;
    TipVisable := False;
  end;
end;

// Test it:

procedure TForm1.Button2Click(Sender: TObject);
begin
 
InitListBox;
 CreateTipsWindow;
end;

end.

end.


 

printed from
www.swissdelphicenter.ch
developers knowledge base