Подсказки на месте используются для отображения текстовых строк для объектов, которые были обрезаны,

Например, в TreeView. Следующий код был протестирован только на стандартный элемент управления listbox.

После соответствующей модификации вы можете использовать советы по другим виртуальным видеомагнитофонам.

 (Скопируйте только следующий код в файл блока Form1)

Code:

 

//------------------------------------------------------------------------------

//  Show in-place tooltips on ListBox

//  Author??Joe Huang                 Email??Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.

//

//------------------------------------------------------------------------------

 

 

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: Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра.');

ListBox1.Items.Append('Delphi 5 Developers 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.

 

Добавить комментарий

Не использовать не нормативную лексику.

Просьба писать ваши замечания, наблюдения и все остальное,
что поможет улучшить предоставляемую информацию на этом сайте.

ВСЕ КОММЕНТАРИИ МОДЕРИРУЮТСЯ ВРУЧНУЮ, ТАК ЧТО СПАМИТЬ БЕСПОЛЕЗНО!


Защитный код
Обновить