ewsdr/FlatEdit.pas

unit FlatEdit;

{ Custom single-line edit with canvas rendering.
  Use instead of TEdit where native widgetset styling is undesirable. }

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, Graphics, Forms, LCLType, LMessages, Types,
  Clipbrd, Math, LazUTF8, AppTheme;

type
  TFlatEdit = class(TCustomControl)
  private
    FText: string;
    FTextHint: string;
    FPasswordChar: Char;
    FMaxLength: Integer;
    FCaretPos: Integer;
    FSelStart: Integer;
    FSelLen: Integer;
    FHot: Boolean;
    FEditing: Boolean;
    FDragging: Boolean;
    FOnChange: TNotifyEvent;
    FClrOuterBG: TColor;
    FClrBG: TColor;
    FClrBGHot: TColor;
    FClrBorder: TColor;
    FClrText: TColor;
    FClrTextDim: TColor;
    FClrSelBG: TColor;
    FClrSelText: TColor;
    function DpiScale(V: Integer): Integer;
    function DisplayText: string;
    function TextLen: Integer;
    function HasSelection: Boolean;
    function SelFirst: Integer;
    function SelAfter: Integer;
    function CaretPosAtX(X: Integer): Integer;
    procedure SetText(const V: string);
    procedure SetTextHint(const V: string);
    procedure SetPasswordChar(V: Char);
    procedure SetMaxLength(V: Integer);
    procedure SetCaretPos(V: Integer);
    procedure DeleteSelection;
    procedure InsertText(const S: string);
    procedure DoChange;
    procedure AppUserInput(Sender: TObject; Msg: Cardinal);
    procedure CMTextChanged(var Msg: TLMessage); message CM_TEXTCHANGED;
  protected
    procedure Paint; override;
    procedure MouseEnter; override;
    procedure MouseLeave; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure DblClick; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: char); override;
    procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
    procedure DoEnter; override;
    procedure DoExit; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetAppTheme(const T: TAppTheme);
    procedure SelectAll;

    property Text: string read FText write SetText;
    property TextHint: string read FTextHint write SetTextHint;
    property PasswordChar: Char read FPasswordChar write SetPasswordChar;
    property MaxLength: Integer read FMaxLength write SetMaxLength;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Align;
    property Anchors;
    property Enabled;
    property Font;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Tag;
    property Visible;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
  end;

implementation

const
  BASE_PAD_X = 8;

constructor TFlatEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque, csCaptureMouse, csClickEvents];
  Width := 120;
  Height := DpiScale(26);
  TabStop := True;
  Cursor := crIBeam;
  FMaxLength := 0;
  FCaretPos := 0;
  FSelStart := 0;
  FSelLen := 0;
  FEditing := False;
  FDragging := False;

  Font.Name := 'Courier New';
  Font.Size := 9;

  FClrOuterBG := TColor($00181818);
  FClrBG := TColor($001A1A1A);
  FClrBGHot := TColor($00202020);
  FClrBorder := TColor($00444444);
  FClrText := TColor($00E0E0E0);
  FClrTextDim := TColor($00666666);
  FClrSelBG := TColor($000C3010);
  FClrSelText := TColor($0000FF88);
  Application.AddOnUserInputHandler(@AppUserInput);
end;

destructor TFlatEdit.Destroy;
begin
  Application.RemoveOnUserInputHandler(@AppUserInput);
  inherited Destroy;
end;

function TFlatEdit.DpiScale(V: Integer): Integer;
begin
  Result := MulDiv(V, Screen.PixelsPerInch, 96);
  if (V > 0) and (Result < 1) then
    Result := 1;
end;

procedure TFlatEdit.SetAppTheme(const T: TAppTheme);
begin
  FClrOuterBG := T.Panel;
  FClrBG := T.BtnNorm;
  FClrBGHot := T.BtnHot;
  FClrBorder := T.Border;
  FClrText := T.Text;
  FClrTextDim := T.TextDim;
  FClrSelBG := T.BtnActive;
  FClrSelText := T.BtnTextActive;
  Font.Color := T.Text;
  Invalidate;
end;

function TFlatEdit.DisplayText: string;
begin
  if FPasswordChar <> #0 then
    Result := StringOfChar(FPasswordChar, TextLen)
  else
    Result := FText;
end;

function TFlatEdit.TextLen: Integer;
begin
  Result := UTF8Length(FText);
end;

function TFlatEdit.HasSelection: Boolean;
begin
  Result := FSelLen <> 0;
end;

function TFlatEdit.SelFirst: Integer;
begin
  if FSelLen >= 0 then
    Result := FSelStart
  else
    Result := FSelStart + FSelLen;
end;

function TFlatEdit.SelAfter: Integer;
begin
  if FSelLen >= 0 then
    Result := FSelStart + FSelLen
  else
    Result := FSelStart;
end;

function TFlatEdit.CaretPosAtX(X: Integer): Integer;
var
  I, Pad, RelX, BestDist, Dist: Integer;
  S: string;
begin
  Pad := DpiScale(BASE_PAD_X);
  RelX := X - Pad;
  S := DisplayText;
  Result := 0;
  BestDist := Abs(RelX);
  for I := 1 to UTF8Length(S) do
  begin
    Dist := Abs(RelX - Canvas.TextWidth(UTF8Copy(S, 1, I)));
    if Dist < BestDist then
    begin
      BestDist := Dist;
      Result := I;
    end;
  end;
end;

procedure TFlatEdit.SetText(const V: string);
var
  S: string;
begin
  S := V;
  if (FMaxLength > 0) and (UTF8Length(S) > FMaxLength) then
    S := UTF8Copy(S, 1, FMaxLength);
  if FText = S then Exit;
  FText := S;
  FCaretPos := EnsureRange(FCaretPos, 0, TextLen);
  FSelStart := FCaretPos;
  FSelLen := 0;
  Invalidate;
  DoChange;
end;

procedure TFlatEdit.SetTextHint(const V: string);
begin
  if FTextHint = V then Exit;
  FTextHint := V;
  Invalidate;
end;

procedure TFlatEdit.SetPasswordChar(V: Char);
begin
  if FPasswordChar = V then Exit;
  FPasswordChar := V;
  Invalidate;
end;

procedure TFlatEdit.SetMaxLength(V: Integer);
begin
  FMaxLength := Max(0, V);
  if (FMaxLength > 0) and (UTF8Length(FText) > FMaxLength) then
    SetText(UTF8Copy(FText, 1, FMaxLength));
end;

procedure TFlatEdit.SetCaretPos(V: Integer);
begin
  FCaretPos := EnsureRange(V, 0, TextLen);
  FSelStart := FCaretPos;
  FSelLen := 0;
  Invalidate;
end;

procedure TFlatEdit.DeleteSelection;
var
  A, B: Integer;
begin
  if not HasSelection then Exit;
  A := SelFirst;
  B := SelAfter;
  UTF8Delete(FText, A + 1, B - A);
  FCaretPos := A;
  FSelStart := FCaretPos;
  FSelLen := 0;
end;

procedure TFlatEdit.InsertText(const S: string);
var
  AddText: string;
  SpaceLeft: Integer;
begin
  if S = '' then Exit;
  DeleteSelection;
  AddText := S;
  if FMaxLength > 0 then
  begin
    SpaceLeft := FMaxLength - TextLen;
    if SpaceLeft <= 0 then Exit;
    AddText := UTF8Copy(AddText, 1, SpaceLeft);
  end;
  UTF8Insert(AddText, FText, FCaretPos + 1);
  Inc(FCaretPos, UTF8Length(AddText));
  FSelStart := FCaretPos;
  FSelLen := 0;
  Invalidate;
  DoChange;
end;

procedure TFlatEdit.DoChange;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TFlatEdit.AppUserInput(Sender: TObject; Msg: Cardinal);
var
  P: TPoint;
begin
  if not FEditing then Exit;
  case Msg of
    LM_LBUTTONDOWN, LM_RBUTTONDOWN, LM_MBUTTONDOWN: ;
  else
    Exit;
  end;

  P := ScreenToClient(Mouse.CursorPos);
  if PtInRect(ClientRect, P) then Exit;

  FDragging := False;
  MouseCapture := False;
  FEditing := False;
  FHot := False;
  FSelLen := 0;
  Invalidate;
end;

procedure TFlatEdit.CMTextChanged(var Msg: TLMessage);
begin
  Invalidate;
end;

procedure TFlatEdit.Paint;
var
  R, TextR, SelR: TRect;
  Pad, TextY, CaretX, A, B: Integer;
  S, BeforeSel, SelText: string;
begin
  R := ClientRect;
  Canvas.Brush.Color := FClrOuterBG;
  Canvas.Brush.Style := bsSolid;
  Canvas.Pen.Style := psClear;
  Canvas.FillRect(R);

  if FHot or FEditing then
    Canvas.Brush.Color := FClrBGHot
  else
    Canvas.Brush.Color := FClrBG;
  Canvas.Pen.Color := FClrBorder;
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Width := 1;
  Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

  Canvas.Font.Assign(Font);
  Pad := DpiScale(BASE_PAD_X);
  TextR := Rect(Pad, 0, Width - Pad, Height);
  TextY := (Height - Canvas.TextHeight('Ag')) div 2;

  if (FText = '') and not FEditing and (FTextHint <> '') then
  begin
    Canvas.Brush.Style := bsClear;
    Canvas.Font.Color := FClrTextDim;
    Canvas.TextRect(TextR, TextR.Left, TextY, FTextHint);
    Exit;
  end;

  S := DisplayText;
  if HasSelection then
  begin
    A := SelFirst;
    B := SelAfter;
    BeforeSel := UTF8Copy(S, 1, A);
    SelText := UTF8Copy(S, A + 1, B - A);
    SelR := Rect(TextR.Left + Canvas.TextWidth(BeforeSel), TextY,
      TextR.Left + Canvas.TextWidth(BeforeSel + SelText), TextY + Canvas.TextHeight('Ag'));
    Canvas.Brush.Color := FClrSelBG;
    Canvas.Brush.Style := bsSolid;
    Canvas.Pen.Style := psClear;
    Canvas.FillRect(SelR);
  end;

  Canvas.Brush.Style := bsClear;
  Canvas.Font.Color := FClrText;
  Canvas.TextRect(TextR, TextR.Left, TextY, S);

  if HasSelection then
  begin
    A := SelFirst;
    B := SelAfter;
    BeforeSel := UTF8Copy(S, 1, A);
    SelText := UTF8Copy(S, A + 1, B - A);
    Canvas.Font.Color := FClrSelText;
    Canvas.TextOut(TextR.Left + Canvas.TextWidth(BeforeSel), TextY, SelText);
  end;

  if FEditing and not HasSelection then
  begin
    CaretX := TextR.Left + Canvas.TextWidth(UTF8Copy(S, 1, FCaretPos));
    Canvas.Pen.Color := FClrText;
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Width := 1;
    Canvas.Line(CaretX, TextY, CaretX, TextY + Canvas.TextHeight('Ag'));
  end;
end;

procedure TFlatEdit.MouseEnter;
begin
  inherited;
  FHot := True;
  Invalidate;
end;

procedure TFlatEdit.MouseLeave;
begin
  inherited;
  FHot := False;
  Invalidate;
end;

procedure TFlatEdit.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Pos: Integer;
begin
  inherited;
  if (Button <> mbLeft) or not Enabled then Exit;
  SetFocus;
  FEditing := True;
  FDragging := True;
  MouseCapture := True;
  Pos := CaretPosAtX(X);
  FCaretPos := Pos;
  FSelStart := Pos;
  FSelLen := 0;
  Invalidate;
end;

procedure TFlatEdit.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Pos: Integer;
begin
  inherited;
  if not FDragging then Exit;
  Pos := CaretPosAtX(X);
  FCaretPos := Pos;
  FSelLen := Pos - FSelStart;
  Invalidate;
end;

procedure TFlatEdit.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  if Button <> mbLeft then Exit;
  FDragging := False;
  MouseCapture := False;
  Invalidate;
end;

procedure TFlatEdit.DblClick;
begin
  inherited;
  FEditing := True;
  SelectAll;
end;

procedure TFlatEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  if not Enabled then Exit;
  FEditing := True;
  case Key of
    VK_LEFT:
      begin
        SetCaretPos(FCaretPos - 1);
        Key := 0;
      end;
    VK_RIGHT:
      begin
        SetCaretPos(FCaretPos + 1);
        Key := 0;
      end;
    VK_HOME:
      begin
        SetCaretPos(0);
        Key := 0;
      end;
    VK_END:
      begin
        SetCaretPos(TextLen);
        Key := 0;
      end;
    VK_BACK:
      begin
        if HasSelection then
          DeleteSelection
        else if FCaretPos > 0 then
        begin
          UTF8Delete(FText, FCaretPos, 1);
          Dec(FCaretPos);
        end;
        FSelStart := FCaretPos;
        FSelLen := 0;
        Invalidate;
        DoChange;
        Key := 0;
      end;
    VK_DELETE:
      begin
        if HasSelection then
          DeleteSelection
        else if FCaretPos < TextLen then
          UTF8Delete(FText, FCaretPos + 1, 1);
        FSelStart := FCaretPos;
        FSelLen := 0;
        Invalidate;
        DoChange;
        Key := 0;
      end;
    Ord('A'):
      if ssCtrl in Shift then
      begin
        SelectAll;
        Key := 0;
      end;
    Ord('C'):
      if (ssCtrl in Shift) and HasSelection then
      begin
        Clipboard.AsText := UTF8Copy(FText, SelFirst + 1, SelAfter - SelFirst);
        Key := 0;
      end;
    Ord('X'):
      if (ssCtrl in Shift) and HasSelection then
      begin
        Clipboard.AsText := UTF8Copy(FText, SelFirst + 1, SelAfter - SelFirst);
        DeleteSelection;
        Invalidate;
        DoChange;
        Key := 0;
      end;
    Ord('V'):
      if ssCtrl in Shift then
      begin
        InsertText(Clipboard.AsText);
        Key := 0;
      end;
  end;
end;

procedure TFlatEdit.KeyPress(var Key: char);
begin
  inherited;
  if not Enabled then Exit;
  if Key >= #32 then
    Key := #0;
end;

procedure TFlatEdit.UTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  inherited;
  if not Enabled then Exit;
  FEditing := True;
  if (UTF8Key <> '') and (UTF8Key[1] >= #32) then
  begin
    InsertText(UTF8Key);
    UTF8Key := '';
  end;
end;

procedure TFlatEdit.DoEnter;
begin
  inherited;
  FEditing := True;
  Invalidate;
end;

procedure TFlatEdit.DoExit;
begin
  inherited;
  FEditing := False;
  FHot := False;
  FSelLen := 0;
  Invalidate;
end;

procedure TFlatEdit.SelectAll;
begin
  FSelStart := 0;
  FSelLen := TextLen;
  FCaretPos := TextLen;
  Invalidate;
end;

end.