Delphi - 自定义绘制消息列表

Question

Delphi - 自定义绘制消息列表

Jer*_*dge 1 delphi drawing custom-controls

请参阅我在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.......

Run Code Online (Sandbox Code Playgroud)

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

如何使用TImage代替？关于可能的最大控制尺寸还存在另一个问题.随着消息的增加,此控件会自动增大,因此,如果有1000条消息,平均消息气泡高度约为80像素,则表示网格控制需要高达80,000像素.虽然使用TImage可能很难,因为我必须手动计算画布上的位置来绘制每个气球,类似于网格内部跟踪的方式.

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

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

我不一定要求修复任何东西,而是建议让它成为最好的方法.

Answer 1

And*_*and 8

如果我是你,我会做这样的事情:

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.

Run Code Online (Sandbox Code Playgroud)

即使有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;

Run Code Online (Sandbox Code Playgroud)

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

尽管如此,仍有进一步改进的空间.例如,这是非常愚蠢的,当你添加一个消息字符串列表的末尾重新计算整个缓存阵列.显然,只需将这个新添加的消息的位置附加到缓存数组就足够了.但我把它留给你.

归档时间：	14 年，3 月前
查看次数：	2674 次
最近记录：	7 年，2 月前