delphi - リストボックスキャンバスでの Unicode テキストの描画が遅すぎる

Question

下の画像に示すように、次の形式を使用して、RSS からのニュースをリストボックスに表示しようとしています。スクリーンショットのアプリケーションは、リストボックスをスタイリングすることによって firemonkey で開発されました。VCL アプリケーションで同じものを表示する必要があります。

このレイアウトの要件は次のとおりです。

ニュースのタイトルは太字にする必要があります
短い説明は一番下に配置し、1 行に収まらない場合は折り返す必要があります (画像に示すように)。font-style はノーマルである必要があります
ニュース項目ごとに画像があるはずです

これまでの私のコード:

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;

これが私が得ている出力です:

問題

Unicode テキストの描画が遅すぎて、リストボックスをスクロールしたり、フォームのサイズを変更したりするとちらつきが大きくなります。

ノート

フォントは@Microsoft NeoGothicに設定されています
アイテムの高さ = 70; スタイル = ownerdrawfixed
最初のスクリーンショットに掲載されている firemonkey アプリケーションで同じ Unicode テキストを描画しても問題ありません。
上記のコードは、通常の英語のテキストでは問題なく動作し、ちらつきはまったくありません。この問題は、Unicode テキストにのみ存在します。

更新: DrawTextメソッドのDT_WORDBREAKフラグに問題があるようです。このフラグを削除すると、ちらつきが表示されますが、テキストの描画が大幅に改善されます。

Unicode テキストのサンプル

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

score 0 · Accepted Answer

RSS フィードを表示するために本当に本当に本当に標準の ListBox を使用したい場合は、ダブルバッファリングを使用することをお勧めします。つまり、メモリ内のビットマップに自分のものを描画し、それをlistViewに描画します。ソースコードから、やり方を示す小さなデモを作成しました。すべての問題を解決できるわけではありませんが、標準の VCL コンポーネントで得られる最高のデモだと思います。

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.

delphi - リストボックス キャンバスでの Unicode テキストの描画が遅すぎる

問題

1 に答える 1

Related

Reference

delphi - リストボックスキャンバスでの Unicode テキストの描画が遅すぎる