Как синхронизировать прокрутку двух компонентов TMemo в Delphi: пример кода и решение проблемы отсутствия свойства TopIndex

Delphi , ОС и Железо , Сообщения Windows

Синхронизация прокрутки двух TMemo в Delphi: полное решение

Проблема синхронизации TMemo

Многие разработчики сталкиваются с необходимостью синхронизировать прокрутку двух компонентов TMemo в Delphi. В отличие от TListBox, где для этого есть свойство TopIndex, в TMemo такого свойства нет, что усложняет задачу.

Основные проблемы, с которыми сталкиваются разработчики: - Отсутствие свойства TopIndex в TMemo - Необходимость обработки различных способов прокрутки (мышь, клавиатура, полосы прокрутки) - Синхронизация как вертикальной, так и горизонтальной прокрутки

Решение от Uwe Raabe

Один из лучших вариантов решения - создание производного класса от TMemo с дополнительной функциональностью:

type
  TLinkMemo = class(TMemo)
  private
    FLinkedMemo: TLinkMemo;
    FSkipScroll: Boolean;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure WMHScroll(var Message: TMessage); message WM_HSCROLL;
    procedure WMVScroll(var Message: TMessage); message WM_VSCROLL;
    procedure SyncLink;
    procedure DoScroll(var Message: TMessage);
  public
    property LinkedMemo: TLinkMemo read FLinkedMemo write FLinkedMemo;
  end;

Реализация методов

procedure TLinkMemo.CNCommand(var Message: TWMCommand);
begin
  inherited;
  FSkipScroll := False;
  if (Message.NotifyCode = EN_VSCROLL) or (Message.NotifyCode = EN_HSCROLL) then
  begin
    SyncLink;
    FSkipScroll := True;
  end;
end;

procedure TLinkMemo.DoScroll(var Message: TMessage);
begin
  var saveLinkedMemo := FLinkedMemo;
  try
    FLinkedMemo := nil;
    Perform(Message.Msg, Message.WParam, Message.LParam);
  finally
    FLinkedMemo := saveLinkedMemo;
  end;
end;

procedure TLinkMemo.SyncLink;
begin
  if LinkedMemo = nil then Exit;

  var saveLink := LinkedMemo.LinkedMemo;
  try
    LinkedMemo.LinkedMemo := nil;

    var myFirstVisibleChar := Perform(EM_CHARFROMPOS, 0, 0);
    var linkFirstVisibleChar := LinkedMemo.Perform(EM_CHARFROMPOS, 0, 0);
    if myFirstVisibleChar = linkFirstVisibleChar then Exit;

    var myLineIndex := Perform(EM_LINEFROMCHAR, myFirstVisibleChar, 0);
    var myLineStart := Perform(EM_LINEINDEX, myLineIndex, 0);
    var myCharIndex := myFirstVisibleChar - myLineStart;

    var linkLineIndex := LinkedMemo.Perform(EM_LINEFROMCHAR, linkFirstVisibleChar, 0);
    var linkLineStart := LinkedMemo.Perform(EM_LINEINDEX, linkLineIndex, 0);
    var linkCharIndex := linkFirstVisibleChar - linkLineStart;

    LinkedMemo.CaretPos := CaretPos;
    if myCharIndex < linkCharIndex then
    begin
      LinkedMemo.CaretPos := TPoint.Create(0, myLineIndex);
      LinkedMemo.Perform(EM_SCROLLCARET, 0, 0);
      LinkedMemo.CaretPos := CaretPos;
      linkCharIndex := 0;
    end;
    LinkedMemo.Perform(EM_LINESCROLL, myCharIndex - linkCharIndex, myLineIndex - linkLineIndex);
  finally
    LinkedMemo.LinkedMemo := saveLink;
  end;
end;

procedure TLinkMemo.WMHScroll(var Message: TMessage);
begin
  inherited;
  if FSkipScroll then
  begin
    FSkipScroll := False;
    Exit;
  end;

  if LinkedMemo <> nil then
    LinkedMemo.DoScroll(Message);
end;

procedure TLinkMemo.WMVScroll(var Message: TMessage);
begin
  inherited;
  if FSkipScroll then
  begin
    FSkipScroll := False;
    Exit;
  end;

  if LinkedMemo <> nil then
    LinkedMemo.DoScroll(Message);
end;

Альтернативное решение от Kryvich

Другой подход предлагает Kryvich, который переопределяет WndProc:

type
  TLinkMemo = class(TMemo)
  private
    FLinkedMemo: TLinkMemo;
    procedure SyncLink;
  protected
    procedure WndProc(var Message: TMessage); override;
  public
    property LinkedMemo: TLinkMemo read FLinkedMemo write FLinkedMemo;
  end;

procedure TLinkMemo.WndProc(var Message: TMessage);
begin
  inherited;
  if (LinkedMemo = nil) or not LinkedMemo.HandleAllocated then
    Exit;
  case Message.Msg of
    WM_HSCROLL, WM_VSCROLL, WM_KEYDOWN, WM_MOUSEFIRST..WM_MOUSELAST: SyncLink;
  end;
end;

procedure TLinkMemo.SyncLink;
  procedure UpdateScrollBar(BarFlag: Integer; Msg: Cardinal);
  var
    scrollInfo: TScrollInfo;
  begin
    scrollInfo.cbSize := SizeOf(scrollInfo);
    scrollInfo.fMask  := SIF_POS;
    if GetScrollInfo(Handle, BarFlag, scrollInfo) then
      LinkedMemo.Perform(Msg, MAKEWPARAM(SB_THUMBPOSITION, scrollInfo.nPos), 0);
  end;
var
  savedLink: TLinkMemo;
begin
  savedLink := LinkedMemo.LinkedMemo;
  try
    LinkedMemo.LinkedMemo := nil;
    UpdateScrollBar(SB_HORZ, WM_HSCROLL);
    UpdateScrollBar(SB_VERT, WM_VSCROLL);
  finally
    LinkedMemo.LinkedMemo := savedLink;
  end;
end;

Использование решения

Чтобы использовать любой из этих подходов:

1. Объявите класс TLinkMemo (или используйте interposer-класс TMemo)
2. Добавьте два компонента TMemo на форму
3. В событии FormCreate свяжите их:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1.LinkedMemo := Memo2;
  Memo2.LinkedMemo := Memo1;
end;

Особенности работы

1. Горизонтальная прокрутка: Оба решения поддерживают синхронизацию горизонтальной прокрутки, но могут быть нюансы при использовании колесика мыши.

2. Редактирование текста: При редактировании содержимого одного из Memo синхронизация может нарушиться, так как это не предусмотрено в данных решениях.

3. Производительность: Для очень больших текстов может потребоваться оптимизация кода.

Заключение

Оба представленных решения эффективно решают проблему синхронизации прокрутки двух компонентов TMemo. Выбор между ними зависит от конкретных требований вашего проекта. Решение Uwe Raabe более комплексное и учитывает больше нюансов, в то время как вариант Kryvich проще в реализации.

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

Создано по материалам из источника по ссылке.

В статье представлены два различных решения для синхронизации прокрутки двух компонентов TMemo в Delphi, одно из которых является более комплексным и учитывает больше нюансов, а другое - проще в реализации.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Сообщения Windows ::