| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Как в ListBox красиво обрезать строки по ширине ListBox, и ... [D7, WinXP]

Gear ©   (2004-09-12 17:05:00) 

Как в ListBox красиво обрезать строки по ширине ListBox, и выдавать полную строку в Hint при наведении на неё мышью?

---

Семен Сорокин   (2004-09-12 18:12:00) [1]

отображение имени файла в колонке ListView, можешь попробовать адаптировать.

lv - TListView

function TfmFlights.CalcVisibleString(const AString: string;
 AWidth: integer): string;
var
 _text: string;
 _add: string;
 _i: integer;
begin
if lv.Canvas.TextWidth(AString) < AWidth+2 then
 Result := AString
else begin
 _text := '...' + ExtractFileName(AString);
 _i := 1;
 _add := EmptyStr;
 if lv.Canvas.TextWidth(_add+_text) < AWidth-20 then
  while (lv.Canvas.TextWidth(_add+_text) < AWidth-20) and (_i < Length(AString)-Length(_text)-1) do begin
   _add := _add + AString[_i];
   inc(_i)
  end
 else
  _text := ExtractFileName(AString);
 Result := _add + _text
end
end;

---

QuasiLamo   (2004-09-12 18:10:00) [2]

...

procedureTForm1.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 thenExit;
  ifTipVisable 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);

    ifListBox1.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;

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

// Test it:

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

end.
end.

---

QuasiLamo   (2004-09-12 18:09:00) [3]

{
 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 onListBox
//  Author??Joe Huang                 Email??Happyjoe@21cn.com
//
//------------------------------------------------------------------------------

unitUnit1;

interface

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

type
 // OverrideTListBox's WinProc toget CM_MOUSELEAVE message
 TNewListBox = class(TListBox)
  protected
   { Protected declarations }
    procedureWndProc( var Message: TMessage); override;
  end;

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

    procedureInitListBox;   //Create ListBox1 dynamically
    procedureCreateTipsWindow;  //Create Tooltip Window
    procedureHideTipsWindow;    //Hide Tooltip Window

   //WM_NOTIFY message's handler, fill Tooltip Window content
    procedureWMNotify( varMsg: TMessage); messageWM_NOTIFY;

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

var
 Form1: TForm1;

implementation

{$R *.dfm}

{ TNewListBox }

procedureTNewListBox.WndProc( var Message: TMessage);
begin
  case Message.Msg of
   CM_MOUSELEAVE: Form1.HideTipsWindow;
  end;
  inheritedWndProc( Message);
end;

{ TForm1 }

procedureTForm1.InitListBox;
begin
 ListBox1 := TNewListBox.Create(Self);
 ListBox1.Parent := Self;
 ListBox1.Left := 50;
 ListBox1.Top := 50;
 ListBox1.Width := 200;
 ListBox1.Height := 200;
 //append serveral items fortesting
 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;

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

procedureTForm1.CreateTipsWindow;
var
 iccex: tagINITCOMMONCONTROLSEX;
begin
 // Load the ToolTip classfrom 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 foruse astracking 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;

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

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

procedureTForm1.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 thenExit;
  ifTipVisable then
  begin
   SendMessage(GHWND,TTM_TRACKACTIVATE,Integer(LongBool(False)), 0);
   OldIndex := -1;
   TipVisable := False;
  end else
  begin
   ARect := ListBox1.ItemRect( Index);

    if

---

Gear   (2004-09-12 17:26:00) [4]

может у кого есть наработки? код не кините?

---

Profi   (2004-09-12 17:12:00) [5]

Gear   (12.09.04 17:05)
Заменяй последние три видимых символа точками!

---

Наверх