mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 18:43:51 +00:00
Add custom flat form controls
This commit is contained in:
+586
@@ -0,0 +1,586 @@
|
||||
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.
|
||||
Reference in New Issue
Block a user