ui(beacon): add flat memo with overlay scroll

2026-08-25 17:27:32 +00:00 · 2026-08-05 15:06:48 +03:00
parent 0396eeed49
commit 998cb3f0fe
2 changed files with 284 additions and 11 deletions
@@ -17,7 +17,7 @@ interface
 uses
  Classes, SysUtils, Math, StrUtils,
  Forms, Controls, Graphics, ExtCtrls, StdCtrls,
-  AppTheme, BeaconDecoder, BeaconFEC, RadioController, DpiUtils;
+  AppTheme, BeaconDecoder, BeaconFEC, RadioController, DpiUtils, FlatMemo;

 type
  TBeaconScopeForm = class(TForm)
@@ -30,7 +30,7 @@ type
    FBulletin: TPanel;
    FBulletinTitle: TLabel;
    FBulletinHint: TLabel;
-    FMemo:   TMemo;            // декодированный текст бюллетеня (AO-40 кадры)
+    FMemo:   TFlatMemo;        // декодированный текст бюллетеня (AO-40 кадры)
    FTimer:  TTimer;
    FTheme:  TAppTheme;
    FLastFrames: Int64;        // счётчик кадров на прошлом тике (детект нового)
@@ -135,20 +135,17 @@ begin
  FBulletinHint.Font.Color := FTheme.TextDim;

  // Бюллетень остаётся обычным read-only memo: текст можно выделить и скопировать.
-  FMemo := TMemo.Create(Self);
+  FMemo := TFlatMemo.Create(Self);
  FMemo.Parent := FBulletin;
  FMemo.Align := alClient;
  FMemo.BorderSpacing.Left := DpiScale(12);
  FMemo.BorderSpacing.Top := DpiScale(36);
  FMemo.BorderSpacing.Right := DpiScale(12);
  FMemo.BorderSpacing.Bottom := DpiScale(12);
-  FMemo.BorderStyle := bsNone;
  FMemo.ReadOnly := True;
-  FMemo.ScrollBars := ssVertical;
  FMemo.WordWrap := False;
  FMemo.Font.Size := 9;
-  FMemo.Color := FTheme.BG;
-  FMemo.Font.Color := FTheme.Text;
+  FMemo.SetAppTheme(FTheme);

  FBox := TPaintBox.Create(Self);
  FBox.Parent := Self;
@@ -174,10 +171,7 @@ begin
  if FBulletinTitle <> nil then FBulletinTitle.Font.Color := T.MeterOn;
  if FBulletinHint <> nil then FBulletinHint.Font.Color := T.TextDim;
  if FMemo <> nil then
-  begin
-    FMemo.Color := T.BG;
-    FMemo.Font.Color := T.Text;
-  end;
+    FMemo.SetAppTheme(T);
  if FBox <> nil then FBox.Invalidate;
 end;

@@ -0,0 +1,279 @@
+unit FlatMemo;
+
+{
+  Read-only/editable memo с полностью управляемым оформлением и тонким
+  overlay-scrollbar. Внутри остаётся обычный TMemo, поэтому выделение,
+  клавиатура и копирование работают штатно на всех LCL widgetset.
+}
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Math, Types,
+  Forms, Controls, Graphics, StdCtrls, ExtCtrls,
+  AppTheme, DpiUtils, OverlayScrollBar;
+
+type
+  TFlatMemo = class(TCustomControl)
+  private
+    FMemo: TMemo;
+    FScrollHost: TPanel;
+    FScrollBar: TOverlayScrollBar;
+    FTheme: TAppTheme;
+    FSyncing: Boolean;
+    function GetLines: TStrings;
+    function GetReadOnly: Boolean;
+    procedure SetReadOnly(AValue: Boolean);
+    function GetWordWrap: Boolean;
+    procedure SetWordWrap(AValue: Boolean);
+    function GetSelStart: Integer;
+    procedure SetSelStart(AValue: Integer);
+    function GetText: string;
+    procedure SetText(const AValue: string);
+    procedure MemoChange(Sender: TObject);
+    procedure MemoKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
+    procedure MemoMouseUp(Sender: TObject; Button: TMouseButton;
+      Shift: TShiftState; X, Y: Integer);
+    procedure MemoMouseWheel(Sender: TObject; Shift: TShiftState;
+      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
+    procedure ScrollChanged(Sender: TObject);
+    procedure UpdateScrollBar;
+    procedure LayoutChildren;
+  protected
+    procedure Paint; override;
+    procedure Resize; override;
+    procedure FontChanged(Sender: TObject); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    procedure Append(const AValue: string);
+    procedure SetAppTheme(const T: TAppTheme);
+    procedure SyncScrollBar;
+
+    property Lines: TStrings read GetLines;
+    property ReadOnly: Boolean read GetReadOnly write SetReadOnly;
+    property WordWrap: Boolean read GetWordWrap write SetWordWrap;
+    property SelStart: Integer read GetSelStart write SetSelStart;
+    property Text: string read GetText write SetText;
+    property Align;
+    property Anchors;
+    property BorderSpacing;
+    property Color;
+    property Font;
+    property Enabled;
+    property TabOrder;
+    property TabStop;
+    property Visible;
+  end;
+
+implementation
+
+constructor TFlatMemo.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  ControlStyle := ControlStyle + [csOpaque];
+  Width := DpiScale(300);
+  Height := DpiScale(160);
+  FTheme := DarkTheme;
+  Color := FTheme.BG;
+  TabStop := False;
+
+  FMemo := TMemo.Create(Self);
+  FMemo.Parent := Self;
+  FMemo.Align := alClient;
+  FMemo.BorderSpacing.Around := 1;
+  FMemo.BorderStyle := bsNone;
+  FMemo.ScrollBars := ssVertical;
+  FMemo.WordWrap := False;
+  FMemo.ParentFont := True;
+  FMemo.Color := FTheme.BG;
+  FMemo.Font.Color := FTheme.Text;
+  FMemo.OnChange := @MemoChange;
+  FMemo.OnKeyUp := @MemoKeyUp;
+  FMemo.OnMouseUp := @MemoMouseUp;
+  FMemo.OnMouseWheel := @MemoMouseWheel;
+
+  // TPaintBox сам не может перекрыть оконный TMemo, поэтому scrollbar живёт
+  // внутри отдельного оконного TPanel, поднятого над нативной полосой.
+  FScrollHost := TPanel.Create(Self);
+  FScrollHost.Parent := Self;
+  FScrollHost.BevelOuter := bvNone;
+  FScrollHost.Color := FTheme.BG;
+  FScrollHost.OnMouseWheel := @MemoMouseWheel;
+
+  FScrollBar := TOverlayScrollBar.Create(Self);
+  FScrollBar.Parent := FScrollHost;
+  FScrollBar.Align := alClient;
+  FScrollBar.HoverTarget := Self;
+  FScrollBar.OnMouseWheel := @MemoMouseWheel;
+  FScrollBar.OnPositionChange := @ScrollChanged;
+
+  LayoutChildren;
+  SetAppTheme(FTheme);
+end;
+
+procedure TFlatMemo.Paint;
+begin
+  Canvas.Brush.Style := bsSolid;
+  Canvas.Brush.Color := FTheme.Border;
+  Canvas.FillRect(ClientRect);
+end;
+
+procedure TFlatMemo.Resize;
+begin
+  inherited Resize;
+  LayoutChildren;
+  UpdateScrollBar;
+end;
+
+procedure TFlatMemo.FontChanged(Sender: TObject);
+begin
+  inherited FontChanged(Sender);
+  if FMemo <> nil then
+  begin
+    FMemo.Font.Assign(Font);
+    UpdateScrollBar;
+  end;
+end;
+
+procedure TFlatMemo.LayoutChildren;
+var
+  GutterW: Integer;
+begin
+  if (FMemo = nil) or (FScrollHost = nil) then Exit;
+  GutterW := Max(DpiScale(8), FMemo.VertScrollBar.Size);
+  FScrollHost.SetBounds(Max(1, ClientWidth - GutterW - 1), 1,
+    GutterW, Max(0, ClientHeight - 2));
+  FScrollHost.BringToFront;
+end;
+
+procedure TFlatMemo.UpdateScrollBar;
+var
+  MaxPos, Viewport: Integer;
+begin
+  if FSyncing or (FMemo = nil) or (FScrollBar = nil) then Exit;
+  FSyncing := True;
+  try
+    MaxPos := Max(0, FMemo.VertScrollBar.Range - FMemo.VertScrollBar.Page);
+    Viewport := Max(1, FMemo.VertScrollBar.Page);
+    FScrollBar.SetRange(MaxPos, Viewport);
+    FScrollBar.Position := EnsureRange(FMemo.VertScrollBar.Position, 0, MaxPos);
+    LayoutChildren;
+  finally
+    FSyncing := False;
+  end;
+end;
+
+procedure TFlatMemo.SyncScrollBar;
+begin
+  UpdateScrollBar;
+end;
+
+procedure TFlatMemo.ScrollChanged(Sender: TObject);
+begin
+  if FSyncing or (FMemo = nil) or (FScrollBar = nil) then Exit;
+  FMemo.VertScrollBar.Position := FScrollBar.Position;
+end;
+
+procedure TFlatMemo.MemoMouseWheel(Sender: TObject; Shift: TShiftState;
+  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
+var
+  Step: Integer;
+begin
+  UpdateScrollBar;
+  if (FScrollBar = nil) or (FScrollBar.Maximum <= 0) then Exit;
+  Step := Max(1, FMemo.VertScrollBar.Increment * 3);
+  if WheelDelta > 0 then FScrollBar.ScrollBy(-Step)
+  else if WheelDelta < 0 then FScrollBar.ScrollBy(Step);
+  Handled := WheelDelta <> 0;
+end;
+
+procedure TFlatMemo.MemoChange(Sender: TObject);
+begin
+  UpdateScrollBar;
+end;
+
+procedure TFlatMemo.MemoKeyUp(Sender: TObject; var Key: Word;
+  Shift: TShiftState);
+begin
+  UpdateScrollBar;
+end;
+
+procedure TFlatMemo.MemoMouseUp(Sender: TObject; Button: TMouseButton;
+  Shift: TShiftState; X, Y: Integer);
+begin
+  UpdateScrollBar;
+end;
+
+function TFlatMemo.GetLines: TStrings;
+begin
+  Result := FMemo.Lines;
+end;
+
+function TFlatMemo.GetReadOnly: Boolean;
+begin
+  Result := FMemo.ReadOnly;
+end;
+
+procedure TFlatMemo.SetReadOnly(AValue: Boolean);
+begin
+  FMemo.ReadOnly := AValue;
+end;
+
+function TFlatMemo.GetWordWrap: Boolean;
+begin
+  Result := FMemo.WordWrap;
+end;
+
+procedure TFlatMemo.SetWordWrap(AValue: Boolean);
+begin
+  FMemo.WordWrap := AValue;
+  UpdateScrollBar;
+end;
+
+function TFlatMemo.GetSelStart: Integer;
+begin
+  Result := FMemo.SelStart;
+end;
+
+procedure TFlatMemo.SetSelStart(AValue: Integer);
+begin
+  FMemo.SelStart := AValue;
+  UpdateScrollBar;
+end;
+
+function TFlatMemo.GetText: string;
+begin
+  Result := FMemo.Text;
+end;
+
+procedure TFlatMemo.SetText(const AValue: string);
+begin
+  FMemo.Text := AValue;
+  UpdateScrollBar;
+end;
+
+procedure TFlatMemo.Append(const AValue: string);
+begin
+  FMemo.Append(AValue);
+  UpdateScrollBar;
+end;
+
+procedure TFlatMemo.SetAppTheme(const T: TAppTheme);
+begin
+  FTheme := T;
+  Color := T.BG;
+  if FMemo <> nil then
+  begin
+    FMemo.Color := T.BG;
+    FMemo.Font.Color := T.Text;
+  end;
+  if FScrollHost <> nil then FScrollHost.Color := T.BG;
+  if FScrollBar <> nil then
+    FScrollBar.SetColors(T.BG, T.Border,
+      T.SliderThumbHot, T.SliderThumbDrag);
+  Invalidate;
+end;
+
+end.