Delphi - 自定义绘制消息列表

Question

请引用我在 tek-tips.com 上提出的问题: http://tek-tips.com/viewthread.cfm?qid=1663735&page=1

正如我在其他几个主题中提到的，我正在构建一个控件来几乎复制 iPhone 上的 SMS 文本消息。这仅由包含文本的控件两侧的气泡组成。我已经有一个工作版本，但需要从头开始重新构建它。我想要一些关于某些事情的建议...

您认为存储消息数据列表的最佳方法是什么？我在考虑使用 TCollection，但这可能太重了。目前，我正在使用包含原始文本数据的 TStringList，这些数据已被适本地解析和翻译。这很好用，因为我不必创建任何带有大量不必要属性的额外对象。这只是...

data syntax:
<user_size><deliminator><user><message_size><deliminator><message>

which could look like:
9|djjd4713023|This is a test message!

characters:
SDTTTTTTTTTSSDTTTTTTTTTTTTTTTTTTTTTTT

user_size = 9
deliminator = |
user = djjd47130
etc.......

无论如何，我预计此控件中可能有数千条消息。这让我想到了下一个问题。绘制它的最佳方法。目前，我正在使用 TDrawGrid，并且正在将其转换为 TStringGrid，这样我就可以将文本直接包含在网格中，而不是 TStringList 中。然而，这就是我停下来的地方，因为我想知道是否有比使用网格更好的方法。这很容易，因为它会自动管理存储每个单元格的矩形等。

改用 TImage 怎么样？还有一个问题是最大可能的控件大小。此控件会随着消息的增加而自动变高，因此，如果有 1,000 条消息，消息气泡的平均高度约为 80 像素，这意味着网格控件需要 80,000 像素高。虽然使用 TImage 可能很困难，因为我必须手动计算 Canvas 上的位置以绘制每个气球，类似于网格内部跟踪它的方式。

顺便说一句，这个网格(或其他 Canvas )位于 TScrollBox 内部(最终控件将从 TScrollingWinControl 继承)。这就是它滚动的方式，而实际的 Canvas 本身比控件大得多，大到足以绘制所有消息气球。在控件中滚动实际上是在 TScrollBox 中上下移动以查看显示消息的控件 Canvas 部分。

总结一下我需要完善的部分:- 在列表中存储消息项的轻量级方法(在网格、字符串列表、集合或其他列表中？)- 具有可变高度列表项的可滚动 Canvas (网格、图像或其他列表？)- 允许最大数量的消息保持可变高度？- 能够自定义控件如何响应用户操作以自动向上或向下滚动

我不一定要求解决任何问题，而是提供建议以使其成为最佳方法。

Answer 1

如果我是你，我会这样做:

unit ChatControl;

interface

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

type
  TUser = (User1 = 0, User2 = 1);

  TChatControl = class(TCustomControl)
  private
    FColor1, FColor2: TColor;
    FStrings: TStringList;
    FScrollPos: integer;
    FOldScrollPos: integer;
    FBottomPos: integer;
    FBoxTops: array of integer;
    FInvalidateCache: boolean;
    procedure StringsChanged(Sender: TObject);
    procedure SetColor1(Color1: TColor);
    procedure SetColor2(Color2: TColor);
    procedure SetStringList(Strings: TStringList);
    procedure ScrollPosUpdated;
    procedure InvalidateCache;
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WndProc(var Message: TMessage); override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure Click; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Say(const User: TUser; const S: String): Integer;
    procedure ScrollToBottom;
  published
    property Align;
    property Anchors;
    property Cursor;
    property Font;
    property Color1: TColor read FColor1 write SetColor1 default clSkyBlue;
    property Color2: TColor read FColor2 write SetColor2 default clMoneyGreen;
    property Strings: TStringList read FStrings write SetStringList;
    property TabOrder;
    property TabStop;
  end;

procedure Register;

implementation

uses Math;

procedure Register;
begin
  RegisterComponents('Rejbrand 2009', [TChatControl]);
end;

{ TChatControl }

procedure TChatControl.Click;
begin
  inherited;
  if CanFocus and TabStop then
    SetFocus;
end;

constructor TChatControl.Create(AOwner: TComponent);
begin
  inherited;

  DoubleBuffered := true;

  FScrollPos := 0;
  FBoxTops := nil;
  InvalidateCache;

  FStrings := TStringList.Create;
  FStrings.OnChange := StringsChanged;
  FColor1 := clSkyBlue;
  FColor2 := clMoneyGreen;

  FOldScrollPos := MaxInt;
end;

procedure TChatControl.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or WS_VSCROLL;
end;

destructor TChatControl.Destroy;
begin
  FStrings.Free;
  inherited;
end;

function TChatControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
begin
  dec(FScrollPos, WheelDelta);
  ScrollPosUpdated;
end;

procedure TChatControl.InvalidateCache;
begin
  FInvalidateCache := true;
end;

procedure TChatControl.Paint;
const
  Aligns: array[TUser] of integer = (DT_RIGHT, DT_LEFT);
var
  Colors: array[TUser] of TColor;
var
  User: TUser;
  i, y, MaxWidth, RectWidth: integer;
  r, r2: TRect;
  SI: TScrollInfo;
begin

  inherited;

  Colors[User1] := FColor1;
  Colors[User2] := FColor2;

  y := 10 - FScrollPos;
  MaxWidth := ClientWidth div 2;

  Canvas.Font.Assign(Font);

  if FInvalidateCache then
    SetLength(FBoxTops, FStrings.Count);

  for i := 0 to FStrings.Count - 1 do
  begin

    if FInvalidateCache then
      FBoxTops[i] := y + FScrollPos
    else
    begin
      if (i < (FStrings.Count - 1)) and (FBoxTops[i + 1] - FScrollPos < 0) then
        Continue;
      if FBoxTops[i] - FScrollPos > ClientHeight then
        Break;
      y := FBoxTops[i] - FScrollPos;
    end;

    User := TUser(FStrings.Objects[i]);

    Canvas.Brush.Color := Colors[User];

    r := Rect(10, y, MaxWidth, 16);
    DrawText(Canvas.Handle,
      PChar(FStrings[i]),
      Length(FStrings[i]),
      r,
      Aligns[User] or DT_WORDBREAK or DT_CALCRECT);

    if User = User2 then
    begin
      RectWidth := r.Right - r.Left;
      r.Right := ClientWidth - 10;
      r.Left := r.Right - RectWidth;
    end;

    r2 := Rect(r.Left - 4, r.Top - 4, r.Right + 4, r.Bottom + 4);
    Canvas.RoundRect(r2, 5, 5);

    DrawText(Canvas.Handle,
      PChar(FStrings[i]),
      Length(FStrings[i]),
      r,
      Aligns[User] or DT_WORDBREAK);

    if FInvalidateCache then
    begin
      y := r.Bottom + 10;
      FBottomPos := y + FScrollPos;
    end;

  end;

  SI.cbSize := sizeof(SI);
  SI.fMask := SIF_ALL;
  SI.nMin := 0;
  SI.nMax := FBottomPos;
  SI.nPage := ClientHeight;
  SI.nPos := FScrollPos;
  SI.nTrackPos := SI.nPos;

  SetScrollInfo(Handle, SB_VERT, SI, true);

  if FInvalidateCache then
    ScrollToBottom;

  FInvalidateCache := false;

end;

procedure TChatControl.Resize;
begin
  inherited;
  InvalidateCache;
  Invalidate;
end;

function TChatControl.Say(const User: TUser; const S: String): Integer;
begin
  result := FStrings.AddObject(S, TObject(User));
end;

procedure TChatControl.ScrollToBottom;
begin
  Perform(WM_VSCROLL, SB_BOTTOM, 0);
end;

procedure TChatControl.SetColor1(Color1: TColor);
begin
  if FColor1 <> Color1 then
  begin
    FColor1 := Color1;
    Invalidate;
  end;
end;

procedure TChatControl.SetColor2(Color2: TColor);
begin
  if FColor2 <> Color2 then
  begin
    FColor2 := Color2;
    Invalidate;
  end;
end;

procedure TChatControl.SetStringList(Strings: TStringList);
begin
  FStrings.Assign(Strings);
  InvalidateCache;
  Invalidate;
end;

procedure TChatControl.StringsChanged(Sender: TObject);
begin
  InvalidateCache;
  Invalidate;
end;

procedure TChatControl.WndProc(var Message: TMessage);
var
  SI: TScrollInfo;
begin
  inherited;
  case Message.Msg of
    WM_GETDLGCODE:
      Message.Result := Message.Result or DLGC_WANTARROWS;
    WM_KEYDOWN:
      case Message.wParam of
        VK_UP:
          Perform(WM_VSCROLL, SB_LINEUP, 0);
        VK_DOWN:
          Perform(WM_VSCROLL, SB_LINEDOWN, 0);
        VK_PRIOR:
          Perform(WM_VSCROLL, SB_PAGEUP, 0);
        VK_NEXT:
          Perform(WM_VSCROLL, SB_PAGEDOWN, 0);
        VK_HOME:
          Perform(WM_VSCROLL, SB_TOP, 0);
        VK_END:
          Perform(WM_VSCROLL, SB_BOTTOM, 0);
      end;
    WM_VSCROLL:
      begin
        case Message.WParamLo of
          SB_TOP:
            begin
              FScrollPos := 0;
              ScrollPosUpdated;
            end;
          SB_BOTTOM:
            begin
              FScrollPos := FBottomPos - ClientHeight;
              ScrollPosUpdated;
            end;
          SB_LINEUP:
            begin
              dec(FScrollPos);
              ScrollPosUpdated;
            end;
          SB_LINEDOWN:
            begin
              inc(FScrollPos);
              ScrollPosUpdated;
            end;
          SB_PAGEUP:
            begin
              dec(FScrollPos, ClientHeight);
              ScrollPosUpdated;
            end;
          SB_PAGEDOWN:
            begin
              inc(FScrollPos, ClientHeight);
              ScrollPosUpdated;
            end;
          SB_THUMBTRACK:
            begin
              ZeroMemory(@SI, sizeof(SI));
              SI.cbSize := sizeof(SI);
              SI.fMask := SIF_TRACKPOS;
              if GetScrollInfo(Handle, SB_VERT, SI) then
              begin
                FScrollPos := SI.nTrackPos;
                ScrollPosUpdated;
              end;
            end;
        end;
        Message.Result := 0;
      end;
  end;
end;

procedure TChatControl.ScrollPosUpdated;
begin
  FScrollPos := EnsureRange(FScrollPos, 0, FBottomPos - ClientHeight);
  if FOldScrollPos <> FScrollPos then
    Invalidate;
  FOldScrollPos := FScrollPos;
end;

end.

即使有 10 000 条消息，这也是超快的。

要测试它，做类似的事情

procedure TForm4.Button1Click(Sender: TObject);
var
  i: integer;
begin
  ChatControl1.Strings.Clear;
  for i := 0 to StrToInt(LabeledEdit1.Text) - 1 do
    ChatControl1.Say(TUser(Random(2)), RandomString(2, 80));
end;

procedure TForm4.Edit2KeyPress(Sender: TObject; var Key: Char);
begin
  Assert(Sender is TEdit);
  if ord(Key) = VK_RETURN then
  begin
    ChatControl1.Say(TUser(TEdit(Sender).Tag), TEdit(Sender).TExt);
    Key := #0;
    TEdit(Sender).Clear;
  end;
end;

完整源代码和编译演示:ChatControlDemo.zip

不过，肯定还有进一步改进的空间。例如，当您将一条消息添加到字符串列表的末尾时，重新计算整个缓存数组是非常愚蠢的。显然，只需将这条新添加的消息的位置附加到缓存数组就足够了。但我把它留给你。