Горизонт. скроллинг в лист-боксе

← →
Roo (2005-05-31 17:28) [0]

Кто-нибудь знает, как можно реализовать горизонтальный скроллинг в лист-боксе ??? Подскажите пожалуйста.

← →
Игорь Шевченко © (2005-05-31 17:29) [1]

LB_SETHORIZONTALEXTENT

← →
begin...end © (2005-05-31 17:30) [2]

TCustomListBox.ScrollWidth или LB_SETHORIZONTALEXTENT

← →
Roo (2005-05-31 17:43) [3]

Там вроде надо указывать точное значение ширины. А как мне узнать макс. ширину айтема ???

← →
Игорь Шевченко © (2005-05-31 17:47) [4]

Roo (31.05.05 17:43) [3]

> А как мне узнать макс. ширину айтема ???

Canvas.TextWidth ?

← →
Amoeba © (2005-05-31 17:59) [5]

Полный код компонета - наследника TListBox обладающего всей нужной функциональностью есть в книжке Тейксейры и Пачеко. В эл. виде она есть на сайте А.Подгорецкого.

← →
Roo (2005-05-31 18:03) [6]

Большое спасибо!!! Получилось :))

← →
Roo (2005-05-31 18:09) [7]

Amoeba, а дайте ссылку сайта.

← →
charlie (2005-05-31 19:18) [8]

Что-то тема стала популярна, может в FAQ положить?
Недели две назад или три выкладывал этот текст:

{
Copyright © 1998 by Delphi 4 Developer"s Guide - Xavier Pacheco and Steve Teixeira
}

unit Lbtab;

interface

uses
SysUtils, Windows, Messages, Classes, Controls, StdCtrls;

type

EddgTabListboxError = class(Exception);

TddgTabListBox = class(TListBox)
private
FLongestString: Word;
FNumTabStops: Word;
FTabStops: PWord;
FSizeAfterDel: Boolean;
function GetLBStringLength(S: String): word;
procedure FindLongestString;
procedure SetScrollLength(S: String);
procedure LBAddString(var Msg: TMessage); message lb_AddString;
procedure LBInsertString(var Msg: TMessage); message lb_InsertString;
procedure LBDeleteString(var Msg: TMessage); message lb_DeleteString;
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
procedure SetTabStops(A: array of word);
published
property SizeAfterDel: Boolean read FSizeAfterDel write FSizeAfterDel default True;
end;

implementation

uses PixDlg;

constructor TddgTabListBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FSizeAfterDel := True;
{ set tab stops to Windows defaults... }
FNumTabStops := 1;
GetMem(FTabStops, SizeOf(Word) * FNumTabStops);
FTabStops^ := DialogUnitsToPixelsX(32);
end;

procedure TddgTabListBox.SetTabStops(A: array of word);
{ This procedure sets the listbox"s tabstops to those specified
in the open array of word, A. New tabstops are in pixels, and must
be in ascending order. An exception will be raised if new tabs
fail to set. }
var
i: word;
TempTab: word;
TempBuf: PWord;
begin
{ Store new values in temps in case exception occurs in setting tabs }
TempTab := High(A) + 1; // Figure number of tabstops
GetMem(TempBuf, SizeOf(A)); // Allocate new tabstops
Move(A, TempBuf^, SizeOf(A));// copy new tabstops }
{ convert from pixels to dialog units, and... }
for i := 0 to TempTab - 1 do
A[i] := PixelsToDialogUnitsX(A[i]);
{ Send new tabstops to listbox. Note that we must use dialog units. }
if Perform(lb_SetTabStops, TempTab, Longint(@A)) = 0 then
begin
{ if zero, then failed to set new tabstops, free temp
tabstop buffer and raise an exception }
FreeMem(TempBuf, SizeOf(Word) * TempTab);
raise EddgTabListboxError.Create("Failed to set tabs.")
end
else begin
{ if nonzero, then new tabstops set okay, so
Free previous tabstops }
FreeMem(FTabStops, SizeOf(Word) * FNumTabStops);
{ copy values from temps... }
FNumTabStops := TempTab; // set number of tabstops
FTabStops := TempBuf; // set tabstop buffer
FindLongestString; // reset scrollbar
Invalidate; // repaint
end;
end;

procedure TddgTabListBox.CreateParams(var Params: TCreateParams);
{ We must OR in the styles necessary for tabs and horizontal scrolling
These styles will be used by the API CreateWindowEx() function. }
begin
inherited CreateParams(Params);
{ lbs_UseTabStops style allows tabs in listbox
ws_HScroll style allows horizontal scrollbar in listbox }
Params.Style := Params.Style or lbs_UseTabStops or ws_HScroll;
end;

function TddgTabListBox.GetLBStringLength(S: String): word;
{ This function returns the length of the listbox string S in pixels }
var
Size: Integer;
begin
// Get the length of the text string
Canvas.Font := Font;
Result := LoWord(GetTabbedTextExtent(Canvas.Handle, PChar(S),
StrLen(PChar(S)), FNumTabStops, FTabStops^));
// Add a little bit of space to the end of the scrollbar extent for looks
Size := Canvas.TextWidth("X");
Inc(Result, Size);
end;

procedure TddgTabListBox.SetScrollLength(S: String);
{ This procedure resets the scrollbar extent if S is longer than the }
{ previous longest string }
var
Extent: Word;
begin
Extent := GetLBStringLength(S);
// If this turns out to be the longest string...
if Extent > FLongestString then
begin
// reset longest string
FLongestString := Extent;
//reset scrollbar extent
Perform(lb_SetHorizontalExtent, Extent, 0);
end;
end;

procedure TddgTabListBox.LBInsertString(var Msg: TMessage);
{ This procedure is called in response to a lb_InsertString message.
This message is sent to the listbox every time a string is inserted.
Msg.lParam holds a pointer to the null-terminated string being
inserted. This will cause the scrollbar length to be adjusted if
the new string is longer than any of the existing strings. }
begin
inherited;
SetScrollLength(PChar(Msg.lParam));
end;

procedure TddgTabListBox.LBAddString(var Msg: TMessage);
{ This procedure is called in response to a lb_AddString message.
This message is sent to the listbox every time a string is added.
Msg.lParam holds a pointer to the null-terminated string being
added. This Will cause the scrollbar length to be ajdusted if the
new string is longer than any of the existing strings.}
begin
inherited;
SetScrollLength(PChar(Msg.lParam));
end;

procedure TddgTabListBox.FindLongestString;
var
i: word;
Strg: String;
begin
FLongestString := 0;
{ iterate through strings and look for new longest string }
for i := 0 to Items.Count - 1 do
begin
Strg := Items[i];
SetScrollLength(Strg);
end;
end;

procedure TddgTabListBox.LBDeleteString(var Msg: TMessage);
{ This procedure is called in response to a lb_DeleteString message.
This message is sent to the listbox everytime a string is deleted.
Msg.wParam holds the index of the item being deleted. Note that
by setting the SizeAfterDel property to False, you can cause the
scrollbar update to not occur. This will improve performance
if you"re deleting often. }
var
Str: String;
begin
if FSizeAfterDel then
begin
Str := Items[Msg.wParam]; // Get string to be deleted
inherited; // Delete string
{ Is deleted string the longest? }
if GetLBStringLength(Str) = FLongestString then
FindLongestString;
end
else
inherited;
end;

end.

← →
charlie (2005-05-31 19:21) [9]

И дополнительный модуль:
{
Copyright © 1999 by Delphi 5 Developer"s Guide - Xavier Pacheco and Steve Teixeira
}

unit Pixdlg;

interface

function DialogUnitsToPixelsX(DlgUnits: word): word;
function DialogUnitsToPixelsY(DlgUnits: word): word;
function PixelsToDialogUnitsX(PixUnits: word): word;
function PixelsToDialogUnitsY(PixUnits: word): word;

implementation

uses WinProcs;

function DialogUnitsToPixelsX(DlgUnits: word): word;
begin
Result := (DlgUnits * LoWord(GetDialogBaseUnits)) div 4;
end;

function DialogUnitsToPixelsY(DlgUnits: word): word;
begin
Result := (DlgUnits * HiWord(GetDialogBaseUnits)) div 8;
end;

function PixelsToDialogUnitsX(PixUnits: word): word;
begin
Result := PixUnits * 4 div LoWord(GetDialogBaseUnits);
end;

function PixelsToDialogUnitsY(PixUnits: word): word;
begin
Result := PixUnits * 8 div HiWord(GetDialogBaseUnits);
end;

end.

ЗЫЖ Кстати сайт Подгорецкого посетить все-равно не помешает, все на форуме не вывалишь. А ссылку на его сайт посмотри там: ©, т.е. http://www.delphimaster.ru/cgi-bin/anketa.pl?id=1084898666

Горизонт. скроллинг в лист-боксе Найти похожие ветки