diff --git a/BeaconScopeForm.pas b/BeaconScopeForm.pas index 27e2fcd..3bda2a9 100644 --- a/BeaconScopeForm.pas +++ b/BeaconScopeForm.pas @@ -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; diff --git a/FlatMemo.pas b/FlatMemo.pas new file mode 100644 index 0000000..b91b2b6 --- /dev/null +++ b/FlatMemo.pas @@ -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.