Delphi - Пользовательский рисунок списка сообщений

Question

Пожалуйста, обратитесь к моему вопросу, заданному на tek-tips.com: http://tek -tips.com / viewthread.cfm? QID = 1663735 & страница = 1

Как я уже упоминал в нескольких других моих темах, я создаю элемент управления, чтобы в значительной степени реплицировать текстовые сообщения SMS на iPhone. Он состоит из просто пузырька с обеих сторон элемента управления, содержащего текст. У меня уже есть рабочая версия, но нужно пересобрать ее с нуля. Я хотел бы получить совет по некоторым вопросам ...

Какой способ хранения списка сообщений вы считаете лучшим? Я думал об использовании 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 вместо этого? Есть еще одна проблема с максимально возможным размером элемента управления. Этот элемент управления автоматически увеличивается с увеличением количества сообщений, поэтому, опять же, если имеется, например, 1000 сообщений со средней высотой пузырьков сообщений около 80 пикселей, это означает, что элемент управления сеткой должен иметь высоту 80 000 пикселей. Однако использовать TImage может быть сложно, потому что тогда мне придется вручную вычислять позицию на этом холсте, чтобы нарисовать каждый шарик, подобно тому, как сетки отслеживают это внутри.

Кстати, эта сетка (или иное полотно) находится внутри TScrollBox (конечный элемент управления наследуется от TScrollingWinControl). Это то, как он может прокручивать, тогда как фактический холст сам по себе намного больше, чем элемент управления, достаточно большой, чтобы нарисовать все всплывающие сообщения. Прокрутка в элементе управления фактически перемещается вверх и вниз в TScrollBox, чтобы увидеть части холста элемента управления, отображающие сообщения.

Чтобы подвести итог кусков, которые мне нужно усовершенствовать: - Облегченный способ хранения элементов сообщения в списке (внутри сетки, списка строк, коллекции или другого списка?) - Прокручиваемый холст с элементами списка переменной высоты (сетка, изображение или другой список?) - Разрешить максимальное количество сообщений для хранения с переменной высотой? - Возможность настроить реакцию элемента управления на действия пользователя для автоматической прокрутки вверх или вниз

Я не обязательно прошу что-то исправить, а скорее совет, чтобы сделать это наилучшим образом.

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 сообщений.

To test it, do something like

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;

Full source and compiled demo: ChatControlDemo.zip

Тем не менее, безусловно, есть место для дальнейших улучшений.Например, довольно глупо пересчитывать весь массив кэша, когда вы добавляете одно сообщение в конец списка строк.Понятно, что достаточно просто добавить позицию этого вновь добавленного сообщения в массив кеша.Но я оставляю это на ваше усмотрение.