各位大大，怎样将Listbox的item的单行显示改变为支持多行？ 以前有类似的控件： http://delphi.ktop.com.tw/topic.php?topic_id=4774 但是，这个控件BUG多多，不知道有没有新版本，或者是别的控件，又或者直接重定义的办法？

这个控件的1.3版本的源代码在这里，它处理较长的中文的时候，会出现错误，请哪位能看看怎么修改？ { ================================================================================== 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[i] = ' ')) 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 k, m, q: integer; bx, cx: String; hecho: boolean; 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 q: integer; qx: String; hecho: boolean; 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); 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: 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: 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[i]); 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[i]); 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[i]); 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.

可能找到原因了，因为它按英文来自动截断换行，所以导致错误。 正在看代码，解决中、、、

初步搞定！但其中对于标点符号（中英文）的自动分行还没有完善，有兴趣的不妨自己动手了。 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 {---------------------------------------------------------------------------} Function izqc(ax: String; c: char): String; Begin If pos(c, ax) = 0 Then Result := '' Else Result := copy(ax, 1, pos(c, ax) - 1); End; Function derc(ax: String; c: char): String; Begin If pos(c, ax) = 0 Then Result := '' Else Result := copy(ax, pos(c, ax) 1, length(ax) - pos(c, ax)); End; Procedure wrapone(ax: String; tl: tstrings; can: tcanvas; n: integer); Var k, m, q: integer; bx, cx: String; hecho: boolean; Begin ax := TrimRight(ax); hecho := false; q := 1; Repeat inc(q); If q > 100 Then hecho := true; k := can.textwidth(ax); If k <= n Then Begin {---当宽度在一行以内 --} tl.add(ax); hecho := true; End Else Begin {---当宽度超出一行 --} m := 1; bx := ax[m]; If IsDBCSLeadByte(byte(bx[m])) Then Begin inc(m); bx := bx ax[m]; End; While (can.textwidth(bx) < n) Do Begin inc(m); bx := bx ax[m]; If IsDBCSLeadByte(byte(bx[m])) Then Begin inc(m); bx := bx ax[m]; End; End; If IsDBCSLeadByte(byte(bx[m])) Then //如果最后一个字符为中文，后退两个字符 m := m - 2; bx := copy(ax, 1, m); cx := copy(ax, m 1, length(ax) - m); //这里还应该改为对中文标点符号的自动分行判断 While (bx[m] <> ' ') And (Not IsDBCSLeadByte(byte(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 q: integer; qx: String; hecho: boolean; Begin ax := TrimRight(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); 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: 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: 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[i]); 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[i]); 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[i]); 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.

引言: 各位大大，怎样将Listbox的item的单行显示改变为支持多行？ 以前有类似的控件： http://delphi.ktop.com.tw/topic.php?topic_id=4774 但是，这个控件BUG多多，不知道有没有新版本，或者是别的控件，又或者直接重定义的办法？

procedure TForm1.ListBox1DrawItem(.... var Str:String; begin with ListBox1 do begin Text:=Items[Index]; Canvas.FillRect(Rect); DrawText(Canvas.Handle,PChar(Text), Length(Text),Rect,DT_WORDBREAK); end; end;