问题

I am trying to display news from a RSS in a listbox using the following format as shown in the image below. The application on the screenshot has been developed in firemonkey by styling the listbox. I need to display the same in my VCL application.

The requirements of this layout are:

The news title should be bold text
The short description should be located at bottom and it should be wrapped if it doesn't fit in a single line(as shown in the image); font-style should be normal
There should be an image for each news item

My code so far:

procedure TfrmDatePicker.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
  R: TRect;
begin
  ListBox1.Canvas.Font.Color := clBlack;
  ListBox1.Canvas.Font.Style := [fsBold];

  ListBox1.Canvas.Font.Size := 9;

  if Odd(Index) then ListBox1.Canvas.Brush.Color := clWhite
  else ListBox1.Canvas.Brush.Color := clBtnFace;

  ListBox1.Canvas.FillRect (Rect);
  ListBox1.Canvas.Pen.Color := clHighlight;

  if(odSelected in State) then
  begin
      ListBox1.Canvas.Font.Color := clHighlightText;
      ListBox1.Canvas.Brush.Color := clHighlight;
      ListBox1.Canvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
      if(odFocused in State) then DrawFocusRect(ListBox1.Canvas.Handle, Rect);
  end;

  ImageList1.Draw(ListBox1.Canvas, Rect.Left + 2,
          Rect.top + (ListBox1.ItemHeight - ImageList1.Height) div 2, Index, true);


  ListBox1.Canvas.TextOut(Rect.Left + 70, Rect.Top + 4, 'कान्तिपुर समाचारआजकोपत्रिकामाकेहिछैन');

  ListBox1.Canvas.Font.Style := ListBox1.Canvas.Font.Style - [fsBold];

  R := Rect;
  R.Left := R.Left + 70;
  R.Top := R.Top + 32;
  R.Height := 30;

  DrawText(ListBox1.Canvas.Handle, PChar(ss), Length(ss), R, DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
  ListBox1.Canvas.TextOut(Rect.Right - 80, Rect.top + 4, '5 mins ago');
end;

Here is the output I am getting:

Problem

Unicode text drawing is too slow and it flickers too much when the listbox is scrolled or the form is resized.

Note

The font has been set to @Microsoft NeoGothic
Itemheight =70; style = ownerdrawfixed
There is no problem in drawing the same unicode text in the firemonkey application posted in the first screenshot.
The code posted above works pretty fine for normal English text and there is no flicker at all. The problem exists only for Unicode text.

Update: It seems the problem is in DT_WORDBREAK flag of DrawText method. Whenever I remove this flag, there is significant improvement in the drawing the text though the flickers are visible.

Sample Unicoide Text

तिम्रो त्यो बोलि ले मलाई बोलायो मिठो तिम्रो त्यो मुस्कान मा मलाई झुलायो झुलाओ ह्स्द्जिः स ह्स्ध्फद्ज द्श्जड्स हस फग स्द्फ़ ग स्द्फ्ग फस ग्स्द्फ़ ग्दस्फ्ग द्स्फग्द तिम्रो त्यो बोलि ले मलाई बोलायो मिठो तिम्रो त्यो मुस्कान मा मलाई स ह्स्ध्फद्ज द्श्जड्स हस फग स्द्फ़ ग स्द्फ्ग फस ग्स्द्फ़ ग्दस्फ्ग द्स्फग्द

回答1:

If you REALY REALY REALY want to use a standard ListBox for displaying you RSS feed I suggest you use double Buffering. Meaning you draw your stuff on a bitmap in memory and den draw that to you listView. From you Sourcecode i've made a small demo showing you how to do.I doesn't solve all the problems but I belive this is the best you can get with a standard VCL component.

unit Unit12;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ImgList;

type
  TForm12 = class(TForm)
    ListBox1: TListBox;
    ImageList1: TImageList;
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    MemBitmap: TBitmap;
    OldListBoxWP: TWndMethod;
    procedure NewListBoxWP(var Message: TMessage);
  public
    { Public declarations }
  end;

var
  Form12: TForm12;

implementation

{$R *.dfm}

const
  NewsStr = 'तिम्रो त्यो बोलि ले मलाई बोलायो मिठो तिम्रो त्यो मुस्कान मा मलाई झुलायो झुल' +
    'ाओ ह्स्द्जिः स ह्स्ध्फद्ज द्श्जड्स हस फग स्द्फ़ ग स्द्फ्ग फस ग्स्द्फ़ ग्दस्फ्ग द्स्फग्द तिम्रो त्यो बोलि ले मलाई बोलायो मिठो तिम्रो त्यो मुस्कान मा मलाई स ह्स्ध्फद्ज द्श्जड्स हस फग स्द्फ़ ग स्द्फ्ग फस ग्स्द्फ़ ग्दस्फ्ग द्स्फग्द';

procedure TForm12.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ListBox1.WindowProc := OldListBoxWP;
  MemBitmap.Free;
end;

procedure TForm12.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  OldListBoxWP := ListBox1.WindowProc;
  ListBox1.WindowProc := NewListBoxWP;
  MemBitmap := TBitmap.Create;
  MemBitmap.SetSize(Width, Height);

  ListBox1.Items.BeginUpdate;
  for i := 0 to 10 do
    ListBox1.Items.Add(NewsStr);
  ListBox1.Items.EndUpdate;
end;

procedure TForm12.FormResize(Sender: TObject);
begin
  MemBitmap.SetSize(Width, Height);
end;

procedure TForm12.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  R: TRect;
begin
  MemBitmap.Canvas.Font.Color := clBlack;
  MemBitmap.Canvas.Font.Style := [fsBold];

  MemBitmap.Canvas.Font.Size := 9;

  if Odd(Index) then
    MemBitmap.Canvas.Brush.Color := clWhite
  else
    MemBitmap.Canvas.Brush.Color := clBtnFace;

  MemBitmap.Canvas.FillRect(Rect);
  MemBitmap.Canvas.Pen.Color := clHighlight;

  if (odSelected in State) then
  begin
    MemBitmap.Canvas.Font.Color := clHighlightText;
    MemBitmap.Canvas.Brush.Color := clHighlight;
    MemBitmap.Canvas.Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    if (odFocused in State) then
      DrawFocusRect(MemBitmap.Canvas.Handle, Rect);
  end;

  ImageList1.Draw(MemBitmap.Canvas, Rect.Left + 2, Rect.Top + (ListBox1.ItemHeight - ImageList1.Height) div 2, Index, true);
  MemBitmap.Canvas.TextOut(Rect.Left + 70, Rect.Top + 4, 'कान्तिपुर समाचारआजकोपत्रिकामाकेहिछैन');

  MemBitmap.Canvas.Font.Style := MemBitmap.Canvas.Font.Style - [fsBold];

  R := Rect;
  R.Left := R.Left + 70;
  R.Top := R.Top + 32;
  R.Height := 30;

  DrawText(MemBitmap.Canvas.Handle, PChar(NewsStr), Length(NewsStr), R, DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);
  MemBitmap.Canvas.TextOut(Rect.Right - 80, Rect.Top + 4, '5 mins ago');

  BitBlt(ListBox1.Canvas.Handle, Rect.Left - 1, Rect.Top - 1, Rect.Right - Rect.Left + 2, Rect.Bottom - Rect.Top + 2, MemBitmap.Canvas.Handle, Rect.Left - 1, Rect.Top - 1, SRCCOPY);
end;

procedure TForm12.NewListBoxWP(var Message: TMessage);
begin
  if Message.Msg = WM_ERASEBKGND then
    Message.Result := 0
  else
    OldListBoxWP(Message);
end;

end.

来源：https://stackoverflow.com/questions/33149592/drawing-unicode-text-on-listbox-canvas-is-too-slow

标签

Delphi