Delphi - Custom drawing a message list

Question

Please refer to my question asked at tek-tips.com: http://tek-tips.com/viewthread.cfm?qid=1663735&page=1

As I mentioned in a couple of my other threads, I\'m bui

Answer 1

If I were you, I'd do something like this:

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.

This is ultra-fast even with 10 000 messages.

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

Still, there is certainly room for further improvements. For example, it is pretty stupid to recompute the entire cache array when you add a single message to the end of the string list. Clearly, it suffices to simply append the position of this newly added message to the cache array. But I leave that up to you.