Показ in-place подсказки в TListBox и других компонентах

{
 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. := 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. := 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.Left);
  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.


Взято с http://delphiworld.narod.ru

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...