ewsdr/FlatMemo.pas

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.