1、可以计算ScrollWidth把横向的滚动条弄出来么！
2、实在喜欢多行的LIST！看下面，一个很不错的，和你的要求非常接近！
{
==================================================================================
TILB
INDENTED LISTBOX COMPONENT V 1.3 Feb-97
By Santiago Portela: sportela@cece.es
Please feel free to copy, modify or distribute this component
==================================================================================
This component displays multiline items in a list box.
Changes to version 1.2 Oct-96:
- Supported linebreak char: '/' . Any line containing '/' will be splitted
- New Font2 property instead of style&color
- Component Name is changed to TILB, to allow using previous version
=================================================================================
TlistBox Descendant. 5 new properties:
indent
PosIndent
DrawLines
DrawLineColor
FontHeader
indent property
inone wraps each item to the number of lines required.
itab split each line where '|' (#124) is found. First part
is displayed aligned to the leftmost part of the component;
second part is displayed left aligned to the indent position
(the indent position is set in property PosIndent).
Text is wrapped to the number of lines required.
iline Same as itab, but instead of spliting vertically the
component, first part is displayed in first line and
second part in the following lines.
Default is inone
PosIndent property
integer Used only when Indent is itab. PosIndent is the position
(in pixels) inside the control where second part of
itms are left aligned.
Default is 48
DrawLines property
boolean Used with itab, iline. If TRUE, a line is drawed below
each item.
DrawLineColor property
Tcolor Color of lines if DrawLine is TRUE.
FontHeader property Font for first part
*BUGS* *BUGS* *BUGS* *BUGS* *BUGS* *BUGS* *BUGS* *BUGS* *BUGS* *BUGS* *BUGS*
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1.If component's font is changed, please refill items list, otherwise the
height of lines is still calculated upon previous font.
2.VERY CAREFULL setting width too small. Component may hang up.
==================================================================================
}
unit Ilb;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TEnumType = (inone,itab,iline);
type
TILB = class(TListBox)
private
Findent:TEnumType; {--- indent option---}
Fi:integer; {--- indent position--}
lista:tstringlist; {--- working list----}
alto:integer; {--default char height--}
LineColor:TColor;
DoDrawLines:boolean; {-- wether draw lines or not--}
FFont2:TFont;
Procedure SetFont2(value:tfont);
Procedure SetIndent(i:TEnumType); {-- sets Findent---}
Function GetIndent:TEnumType; {-- retrieves Findent--}
Procedure SetFi(i:integer); {--sets Fi--}
Function GetFi:integer; {--retrieves Fi--}
protected
Procedure DrawItem(Index:integer;R:trect;State:TownerDrawState);override;
{-- Custom drawing of items in the list---}
Procedure MeasureItem(Index:integer;var altura:integer);override;
{-- Callback to calculate each item height in the list--}
public
constructor Create(owner:tcomponent);override;
destructor Destroy;override;
published
Property DrawLineColor:TColor read LineColor write LineColor;
Property DrawLines:boolean read DoDrawLines write DoDrawLines;
Property FontHeader:tfont read ffont2 write SetFont2;
property Indent:TenumType read GetIndent write SetIndent ;
property PosIndent:integer read GetFi write SetFi;
end;
procedure Register;
implementation
{---------------------------------------------------------------------------}
Procedure rtrim(var ax:string); { rtrim eliminates training whitespaces at the end of the string}
var i:integer;
begin
i:=length(ax);
while((i>0) and (ax=' ')) do dec(i);
ax:=copy(ax,1,i);
end;
function izqc(ax:string;c:char):string;
begin
if pos(c,ax)=0 then izqc:=''
else izqc:=copy(ax,1,pos(c,ax)-1);
end;
function derc(ax:string;c:char):string;
begin
if pos(c,ax)=0 then derc:=''
else derc:=copy(ax,pos(c,ax)+1,length(ax)-pos(c,ax));
end;
Procedure wrapone(ax:string;tl:tstrings;can:tcanvas;n:integer);
var i,j,k,m,q:integer;
bx,cx,qx:string;
hecho:boolean;
hd:HDC;
begin
rtrim(ax);
hecho:=false;
q:=1;
repeat
inc(q);
if q>100 then hecho:=true;
k:=can.textwidth(ax);
if k<=n then begin {---When widht holds in line --}
tl.add(ax);
hecho:=true;
end
else begin {---When widht exceeds line --}
m:=1;
bx:=ax[m];
while (can.textwidth(bx)<n) do begin
inc(m);
bx:=bx+ax[m];
end;
bx:=copy(ax,1,m);
cx:=copy(ax,m+1,length(ax)-m);
while (bx[m]<>' ') do begin
cx:=bx[m]+cx;
dec(m);
end;
bx:=copy(bx,1,m);
tl.add(bx);
ax:=cx;
end;
until hecho;
end;
Procedure wrapx(ax:string;tl:tstrings;can:tcanvas;n:integer);
var i,j,k,m,q:integer;
bx,cx,qx:string;
hecho:boolean;
hd:HDC;
begin
rtrim(ax);
tl.clear;
{-------- Line break control-----}
hecho:=false;
repeat
q:=pos('/',ax);
if q>0 then begin
qx:=izqc(ax,'/');
wrapone(qx,tl,can,n);
ax:=derc(ax,'/');
end
else begin
if ax<>'' then wrapone(ax,tl,can,n);
hecho:=true;
end;
until hecho;
end;
{----------------------------------------------------------------------------}
Constructor TILB.Create(owner:tcomponent);
var i:integer;
begin
inherited create(owner);
ffont2:=tfont.create;
Left := 20;
Top := 20;
Width := 100;
Height := 100;
ItemHeight := font.height+2;
ParentFont := False;
Style := lbOwnerDrawVariable;
Indent := itab;
PosIndent := 48;
DrawLines := True;
DrawLineColor:=clSilver;
lista:=tstringlist.create;
end;
destructor TILB.Destroy;
begin
lista.clear;
lista.destroy;
ffont2.destroy;
inherited destroy;
end;
Procedure TILB.SetFont2(value:tfont);
begin
ffont2.assign(value);
end;
Procedure TILB.SetIndent(i:TEnumType);
begin
if Findent<>i then begin
Findent:=i;
Style := lbOwnerDrawVariable;
invalidate;
end;
end;
Function TILB.GetIndent:TEnumType;
begin
GetIndent:=Findent;
end;
Procedure TILB.SetFi(i:integer);
begin
if Fi<>i then begin
Fi:=i;
invalidate;
end;
end;
Function TILB.GetFi:integer;
begin
GetFi:=Fi;
end;
Procedure TILB.MeasureItem(Index:integer;var altura:integer);
var
al,ancho:integer;
nlines:integer;
ax,bx:string;
postab:integer;
begin
inherited MeasureItem(Index,altura);
al:=altura;
postab:=pos(#124,items[index]);
if postab>0 then begin
ax:=copy(items[index],1,postab-1);
bx:=copy(items[index],postab+1,length(items[index])-postab);
end
else begin
ax:=' ';
bx:=items[index];
end;
canvas.font:=font;
with canvas do begin
if width<=posindent then posindent:=width div 2;
nlines:=1;
alto:=canvas.textheight('|_罬');
case indent of
inone:begin
wrapx(items[index],lista,canvas,width-20);
nlines:=lista.count;
end;
itab:begin
wrapx(bx,lista,canvas,width-posindent-20);
nlines:=lista.count;
end;
iline:begin
wrapx(bx,lista,canvas,width-20);
nlines:=lista.count+1;
end;
end;
end;
altura:=nlines*alto;
canvas.font:=FontHeader;
if abs(canvas.textheight('|_罬'))>altura then altura:=abs(canvas.textheight('|_罬'));
if al>altura then altura:=al;
end;
Procedure TILB.DrawItem(Index:integer;R:trect;State:TownerDrawState);
var
ax,bx:string;
i,j:integer;
postab:integer;
c1,c2:tcolor;
begin
canvas.font:=font;
postab:=pos(#124,items[index]);
if postab>0 then begin
ax:=copy(items[index],1,postab-1);
bx:=copy(items[index],postab+1,length(items[index])-postab);
end
else begin
ax:=' ';
bx:=items[index];
end;
if odselected in state then begin
c1:=rgb(not getrvalue(font.color),not getgvalue(font.color),not getbvalue(font.color));
c2:=rgb(not getrvalue(fontheader.color),not getgvalue(fontheader.color),not getbvalue(fontheader.color));
end
else begin
c1:=font.color;
c2:=fontheader.color;
end;
with Canvas do { draw on the control canvas, not on the form }
begin
FillRect(R); { clear the rectangle }
case indent of
inone:begin
settextcolor(canvas.handle,c1);
wrapx(items[index],lista,canvas,width-20);
for i:=0 to lista.count-1 do
TextOut(R.Left +1, R.Top+i*alto, lista.strings);
end;
itab:begin
wrapx(bx,lista,canvas,width-posindent-20);
lista.add(ax);
canvas.font:=FontHeader;
settextcolor(canvas.handle,c2);
TextOut(r.left,r.top,lista.strings[lista.count-1]);
canvas.font:=Self.font;
settextcolor(canvas.handle,c1);
for i:=0 to lista.count-2 do
TextOut(R.Left +posindent, R.Top+i*alto, lista.strings);
if DoDrawLines then begin
canvas.pen.color:=DrawLineColor;
MoveTo(R.Left , R.bottom-1);
LineTo(R.right, R.bottom-1);
end;
end;
iline:begin
wrapx(bx,lista,canvas,width-20);
lista.add(ax);
canvas.font:=fontheader;
settextcolor(canvas.handle,c2);
TextOut(r.left,r.top,lista.strings[lista.count-1]);
canvas.font:=self.font;
settextcolor(canvas.handle,c1);
for i:=0 to lista.count-2 do
TextOut(R.Left , R.Top+(i+1)*alto, lista.strings);
if DoDrawLines then begin
canvas.pen.color:=DrawLineColor;
MoveTo(R.Left , R.bottom-1);
LineTo(R.right, R.bottom-1);
end;
end;
end;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TILB]);
end;
end.
