Получить соответствие строки экрана строке TStrings в потомке TMemo - PullRequest
Новая
       35

Получить соответствие строки экрана строке TStrings в потомке TMemo

0 голосов
/ 25 апреля 2019

TRichEdit вызывает слишком много нарушений прав доступа и проблем во всплывающем меню при установке стилей, поэтому я пытаюсь создать простой красочный потомок TMemo, в котором каждая строка из Lines может быть нарисована своим собственным цветом, как в целом.

Я не могу влиять на элемент управления для редактирования из Windows, но могу рисовать строки над ним.

Сначала я попытался перебрать свойство Lines, но это вызвало проблемы с прокруткой. Поэтому я решил запросить строки из элемента управления редактирования напрямую, используя Win API.

На данный момент все нарисовано нормально, кроме цветов: строки, запрашиваемые из элемента управления редактированием Windows, - это строки экрана, а не строки из свойства Lines, когда WordWrap := True; и ScrollBars := ssVertical;.

Как узнать на экране -> Lines соответствие номера строки? 

unit ColoredEditMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TMyMemo = class(TMemo)
  private
    procedure WMPaint(var msg: TWMPaint); message WM_PAINT;
  end;

  TForm1 = class(TForm)
  private
    _memo: TMyMemo;
  public
    constructor Create(AOwner: TComponent); override;
  end;

var
  Form1: TForm1;

implementation

uses
  Vcl.Themes;

{$R *.dfm}

{ TMyMemo }

procedure TMyMemo.WMPaint(var msg: TWMPaint);
var
  Buffer: Pointer;
  PS: TPaintStruct;
  DC: HDC;
  i: Integer;
  X, Y: Integer;
  OldColor: LongInt;
  firstLineIdx: Integer;
  charsCopied, lineCount: Integer;
  lineLength: Word;
  bufLength: Integer;
begin
  try
  DC := msg.DC;
  if DC = 0 then
    DC := BeginPaint(Handle, PS);
  try
    X := 5;
    Y := 1;
    SetBkColor(DC, Color);
    SetBkMode(DC, Transparent);
    OldColor := Font.Color;
    firstLineIdx := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
    lineCount := SendMessage(Handle, EM_GETLINECOUNT, 0, 0);
    for i:=firstLineIdx to lineCount-1 do begin
      SelectObject(DC, Font.Handle);
      if odd(i) then
        SetTextColor(DC, clRed)
      else
        SetTextColor(DC, OldColor);
      lineLength := SendMessage(Handle, EM_LINELENGTH, WPARAM(i), 0);
      bufLength := lineLength*2 + 2;
      GetMem(Buffer, bufLength);
      try
        ZeroMemory(Buffer, bufLength);
        PWord(Buffer)^ := lineLength;
        charsCopied := SendMessage(Handle, EM_GETLINE, WPARAM(i), LPARAM(Buffer));
        //ShowMessage(IntToStr(lineLength) + ' ' + IntToStr(charsCopied) + '=' + Strpas(PWideChar(Buffer)));
        if Y > ClientHeight then Exit();
        TextOut(DC, X, Y, PWideChar(Buffer), lineLength);
      finally
        FreeMem(Buffer, bufLength);
      end;
      Inc(Y, Abs(Font.Height) + 2);
    end;
  finally
    if msg.DC = 0 then
      EndPaint(Handle, PS);
  end;
  except
    on ex: Exception do MessageBox(Handle, PWideChar('WMPaint: ' + ex.Message), nil, MB_ICONERROR);
  end;
end;

{ TForm1 }

constructor TForm1.Create(AOwner: TComponent);
var
  i, j: Integer;
  txt: string;
begin
  inherited;
  Left := 5;
  Top := 5;
  _memo := TMyMemo.Create(Self);
  _memo.Parent := Self;
  _memo.Align := alClient;
  _memo.WordWrap := True;
  _memo.ReadOnly := True;
  _memo.ScrollBars := ssVertical;

  for i := 0 to 10 do begin
    txt := '';
    for j := 0 to 100 do
      txt := txt + 'Line ' + IntToStr(i) + '.' + IntToStr(j) + ' ';
    _memo.Lines.Add(txt);
  end;
end;

end.

Обновление

Я всегда думал, что TMemo сохраняет оригинальные строки в своей коллекции Lines, но на самом деле он портит Lines сразу после добавления элемента. Когда перенос по словам включен, добавление действительно длинной строки преобразует ее в несколько строк экрана.

НО! Удивительно, но элемент управления Windows edit внутренне сохраняет исходные строки в целом при изменении размера элемента управления.

...