Capturing signature very sketchy on touch screen

Question

I followed a tutorial for capturing signatures in Firemonkey, and made some major modifications (essentially a re-write) to encapsulate it inside of a custom control. I've written plenty controls in VCL, but this is my first for FMX.

When using this with a mouse (Windows or OS X), it works perfectly. However, when using a touch screen (iOS), it becomes extremely sketchy. Specifically, it keeps capturing a mouse up event (or in this context, "pen up"). So a straight line becomes actually a dashed line. This is a direct result of MouseUp firing repeatedly while gliding one's finger across the touch screen.

Windows:

iOS:

How do I prevent it from capturing "pen up" events when one's finger wasn't actually lifted from the touch screen?

Control Unit: VectorSignature.pas

unit VectorSignature;

interface

uses
  System.Classes, System.SysUtils, System.Types, System.UITypes,
  System.Generics.Collections,
  FMX.Controls, FMX.Objects, FMX.Graphics, FMX.Types;

type
  TSignatureControl = class;

  TVectorState = (vsPenDown, vsPenMove, vsPenUp);

  TVectorPoint = record
    CurPos: TPointF;
    State: TVectorState;
  end;

  TVectorEvent = procedure(Sender: TObject; Point: TVectorPoint) of object;

  TSignatureControl = class(TShape)
  private
    FText: TText;
    FPoints: TList<TVectorPoint>;
    FPenDown: Boolean;
    FCorners: TCorners;
    FSensitivity: Single;
    FOnPenDown: TVectorEvent;
    FOnPenUp: TVectorEvent;
    FOnPenMove: TVectorEvent;
    FOnClear: TNotifyEvent;
    FOnChange: TNotifyEvent;
    function GetPoint(Index: Integer): TVectorPoint;
    function IsCornersStored: Boolean;
    procedure SetSensitivity(const Value: Single);
    procedure SetPromptText(const Value: String);
    function GetPromptText: String;
  protected
    procedure SetCorners(const Value: TCorners); virtual;
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    function Count: Integer;
    procedure AddPoint(const X, Y: Single; State: TVectorState);
    function LastPoint: TVectorPoint;
    function State: TVectorState;
    procedure PaintTo(ACanvas: TCanvas; const Scale: Single = 1.0);
    function MaxDims(const Scale: Single = 1.0): TPointF;
    property Points[Index: Integer]: TVectorPoint read GetPoint; default;
  published
    property Align;
    property Anchors;
    property ClipChildren default False;
    property ClipParent default False;
    property Corners: TCorners read FCorners write SetCorners stored IsCornersStored;
    property Cursor default crDefault;
    property DragMode default TDragMode.dmManual;
    property EnableDragHighlight default True;
    property Enabled default True;
    property Fill;
    property Locked default False;
    property Height;
    property HitTest default True;
    property Padding;
    property Opacity;
    property Margins;
    property PopupMenu;
    property Position;
    property PromptText: String read GetPromptText write SetPromptText;
    property RotationAngle;
    property RotationCenter;
    property Scale;
    property Sensitivity: Single read FSensitivity write SetSensitivity;
    property Size;
    property Stroke;
    property Visible default True;
    property Width;

    {Drag and Drop events}
    property OnDragEnter;
    property OnDragLeave;
    property OnDragOver;
    property OnDragDrop;
    property OnDragEnd;
    {Mouse events}
    property OnPenDown: TVectorEvent read FOnPenDown write FOnPenDown;
    property OnPenUp: TVectorEvent read FOnPenUp write FOnPenUp;
    property OnPenMove: TVectorEvent read FOnPenMove write FOnPenMove;
    property OnClear: TNotifyEvent read FOnClear write FOnClear;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;

    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheel;
    property OnMouseEnter;
    property OnMouseLeave;

    property OnPainting;
    property OnPaint;
    property OnResize;
  end;

implementation

uses
  Math;

function GetDrawingShapeRectAndSetThickness(const AShape: TShape;
  const Fit: Boolean; var FillShape, DrawShape: Boolean;
  var StrokeThicknessRestoreValue: Single): TRectF;
const
  MinRectAreaSize = 0.01;
begin
  FillShape := (AShape.Fill <> nil) and (AShape.Fill.Kind <> TBrushKind.None);
  DrawShape := (AShape.Stroke <> nil) and (AShape.Stroke.Kind <> TBrushKind.None);

  if Fit then
    Result := TRectF.Create(0, 0, 1, 1).FitInto(AShape.LocalRect)
  else
    Result := AShape.LocalRect;

  if DrawShape then
  begin
    if Result.Width < AShape.Stroke.Thickness then
    begin
      StrokeThicknessRestoreValue := AShape.Stroke.Thickness;
      FillShape := False;
      AShape.Stroke.Thickness := Min(Result.Width, Result.Height);
      Result.Left := (Result.Right + Result.Left) * 0.5;
      Result.Right := Result.Left + MinRectAreaSize;
    end
    else
      Result.Inflate(-AShape.Stroke.Thickness * 0.5, 0);

    if Result.Height < AShape.Stroke.Thickness then
    begin
      if StrokeThicknessRestoreValue < 0.0 then
        StrokeThicknessRestoreValue := AShape.Stroke.Thickness;
      FillShape := False;
      AShape.Stroke.Thickness := Min(Result.Width, Result.Height);
      Result.Top := (Result.Bottom + Result.Top) * 0.5;
      Result.Bottom := Result.Top + MinRectAreaSize;
    end
    else
      Result.Inflate(0, -AShape.Stroke.Thickness * 0.5);
  end;
end;

{ TSignatureControl }

constructor TSignatureControl.Create(AOwner: TComponent);
begin
  inherited;
  FPoints:= TList<TVectorPoint>.Create;
  FCorners := [TCorner.TopRight];
  FSensitivity:= 12.0;

  Fill.Kind:= TBrushKind.None;
  Margins.Left:= 8;
  Margins.Top:= 8;
  Margins.Right:= 8;
  Margins.Bottom:= 8;
  Stroke.Thickness:= 2;
  Stroke.Dash:= TStrokeDash.Dash;
  Stroke.Color:= TAlphaColorRec.Gray;

  FText:= TText.Create(Self);
  FText.Parent:= Self;
  FText.Align:= TAlignLayout.Bottom;
  FText.Height:= 40;
  FText.Visible:= True;
  FText.HitTest:= False;
  FText.TextSettings.HorzAlign:= TTextAlign.Center;
  FText.TextSettings.VertAlign:= TTextAlign.Center;
  FText.TextSettings.FontColor:= TAlphaColorRec.Navy;
  FText.TextSettings.Font.Size:= 14;
  FText.TextSettings.Font.Style:= [TFontStyle.fsBold];

  PromptText:= 'Please sign above';
end;

destructor TSignatureControl.Destroy;
begin
  FreeAndNil(FText);
  FreeAndNil(FPoints);
  inherited;
end;

procedure TSignatureControl.Clear;
begin
  FPoints.Clear;
  Repaint;
  if Assigned(FOnClear) then
    FOnClear(Self);
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

function TSignatureControl.Count: Integer;
begin
  Result:= FPoints.Count;
end;

function TSignatureControl.GetPoint(Index: Integer): TVectorPoint;
begin
  Result:= FPoints[Index];
end;

function TSignatureControl.GetPromptText: String;
begin
  Result:= FText.Text;
end;

procedure TSignatureControl.SetPromptText(const Value: String);
begin
  FText.Text:= Value;
  Repaint;
end;

procedure TSignatureControl.SetSensitivity(const Value: Single);
begin
  FSensitivity := Value;
  Repaint;
end;

function TSignatureControl.State: TVectorState;
begin
  Result:= LastPoint.State;
end;

function TSignatureControl.IsCornersStored: Boolean;
begin
  Result := FCorners <> AllCorners;
end;

function TSignatureControl.LastPoint: TVectorPoint;
begin
  Result:= FPoints.Last;
end;

procedure TSignatureControl.AddPoint(const X, Y: Single; State: TVectorState);
var
  P: TVectorPoint;
  D: Single;
begin
  P.CurPos:= PointF(X, Y);
  //Be sure to start with pen down event
  if Count = 0 then P.State:= vsPenDown else P.State:= State;

  case State of
    vsPenDown: begin
      //Always add pen down
      FPoints.Add(P);
      if Assigned(FOnPenDown) then
        FOnPenDown(Self, P);
    end;
    vsPenMove: begin
      D:= P.CurPos.Distance(FPoints.Last.CurPos);
      if D >= FSensitivity then begin
        //Only add new point if it is at least sensitivity distance from last point
        FPoints.Add(P);
        if Assigned(FOnPenMove) then
          FOnPenMove(Self, P);
      end;
    end;
    vsPenUp: begin
      //Always add pen up
      FPoints.Add(P);
      if Assigned(FOnPenUp) then
        FOnPenUp(Self, P);
    end;
  end;
  if Assigned(FOnChange) then
    FOnChange(Self);
  Repaint;
end;

function TSignatureControl.MaxDims(const Scale: Single = 1.0): TPointF;
const
  SIGN_PADDING = 10;
var
  P: TVectorPoint;
begin
  Result.X:= SIGN_PADDING;
  Result.Y:= SIGN_PADDING;
  for P in FPoints do begin
    if (P.CurPos.X ) > (Result.X ) then
      Result.X:= P.CurPos.X ;
    if (P.CurPos.Y ) > (Result.Y ) then
      Result.Y:= P.CurPos.Y ;
  end;
  Result.X:= (Result.X + SIGN_PADDING) * Scale;
  Result.Y:= (Result.Y + SIGN_PADDING) * Scale;
end;

procedure TSignatureControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Single);
begin
  FPenDown:= True;
  AddPoint(X, Y, vsPenDown);
  inherited;
end;

procedure TSignatureControl.MouseMove(Shift: TShiftState; X, Y: Single);
begin
  if ssLeft in Shift then begin
    if FPenDown then begin
      AddPoint(X, Y, vsPenMove);
    end;
  end;
  inherited;
end;

procedure TSignatureControl.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Single);
begin
  FPenDown:= False;
  AddPoint(X, Y, vsPenUp);
  inherited;
end;

procedure TSignatureControl.PaintTo(ACanvas: TCanvas; const Scale: Single = 1.0);
var
  P: TVectorPoint;
  P1, P2: TPointF;
  procedure SetP1(P: TPointF);
  begin
    P1:= P;
    P1.X:= P1.X * Scale;
    P1.Y:= P1.Y * Scale;
  end;
  procedure SetP2(P: TPointF);
  begin
    P2:= P;
    P2.X:= P2.X * Scale;
    P2.Y:= P2.Y * Scale;
  end;
begin
  if not (Count-1 > 0) then Exit;

  ACanvas.BeginScene;
  try
    ACanvas.Stroke.Kind:= TBrushKind.Solid;
    ACanvas.Stroke.Dash:= TStrokeDash.Solid;
    ACanvas.Stroke.Thickness:= (4 * Scale);
    ACanvas.Stroke.Cap:= TStrokeCap.Round;
    ACanvas.Stroke.Color:= TAlphaColorRec.Darkblue;

    for P in FPoints do begin
      case P.State of
        vsPenDown: begin
          SetP1(P.CurPos);
        end;
        vsPenMove: begin
          SetP2(P.CurPos);
          ACanvas.DrawLine(P1, P2, 1, ACanvas.Stroke);
          SetP1(P.CurPos);
        end;
        vsPenUp: begin
          SetP2(P.CurPos);
          ACanvas.DrawLine(P1, P2, 1, ACanvas.Stroke);
        end;
      end;
    end;
  finally
    ACanvas.EndScene;
  end;
end;

procedure TSignatureControl.SetCorners(const Value: TCorners);
begin
  if FCorners <> Value then
  begin
    FCorners := Value;
    Repaint;
  end;
end;

procedure TSignatureControl.Paint;
var
  Radius: Single;
  R: TRectF;
  StrokeThicknessRestoreValue: Single;
  FillShape, DrawShape: Boolean;
  P1, P2: TPointF;
begin
  StrokeThicknessRestoreValue := Stroke.Thickness;
  try
    R := GetDrawingShapeRectAndSetThickness(Self, False, FillShape, DrawShape, StrokeThicknessRestoreValue);

    if Height < Width then
      Radius := R.Height / 2
    else
      Radius := R.Width / 2;

    if FillShape then
      Canvas.FillRect(R, Radius, Radius, FCorners, AbsoluteOpacity, Fill);
    if DrawShape then
      Canvas.DrawRect(R, Radius, Radius, FCorners, AbsoluteOpacity, Stroke);

    //Signature Underline
    P1:= PointF(Margins.Left, Height - 40);
    P2:= PointF(Width - Margins.Right, Height - 40);
    Canvas.DrawLine(P1, P2, 1.0);

  finally
    if StrokeThicknessRestoreValue <> Stroke.Thickness then
      Stroke.Thickness := StrokeThicknessRestoreValue;
  end;
  PaintTo(Canvas);
end;

end.

Test form: uMain.pas

unit uMain;

interface

uses
  System.SysUtils, System.Types, System.UITypes, System.Classes,
  System.Variants, System.Generics.Collections,
  VectorSignature,
  FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects,
  FMX.Layouts, FMX.StdCtrls, FMX.Controls.Presentation, FMX.Memo, FMX.ScrollBox;

type
  TForm1 = class(TForm)
    Layout1: TLayout;
    imgPreview: TRectangle;
    Panel1: TPanel;
    Memo1: TMemo;
    cmdClear: TButton;
    procedure imgPreviewClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure cmdClearClick(Sender: TObject);
    procedure imgPreviewPaint(Sender: TObject; Canvas: TCanvas;
      const ARect: TRectF);
  private
    FSignature: TSignatureControl;
    procedure PenDown(Sender: TObject; Point: TVectorPoint);
    procedure PenMove(Sender: TObject; Point: TVectorPoint);
    procedure PenUp(Sender: TObject; Point: TVectorPoint);
    procedure SignatureClear(Sender: TObject);
    procedure SignatureChange(Sender: TObject);
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.fmx}

uses
  System.IOUtils;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  ReportMemoryLeaksOnShutdown:= True;

  FSignature:= TSignatureControl.Create(nil);
  FSignature.Parent:= Self;
  FSignature.Align:= TAlignLayout.Bottom;
  FSignature.Height:= 200;

  FSignature.OnPenDown:= PenDown;
  FSignature.OnPenMove:= PenMove;
  FSignature.OnPenUp:= PenUp;
  FSignature.OnClear:= SignatureClear;
  FSignature.OnChange:= SignatureChange;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FSignature);
end;

procedure TForm1.cmdClearClick(Sender: TObject);
begin
  FSignature.Clear;
end;

procedure TForm1.imgPreviewClick(Sender: TObject);
const
  SAVE_SCALE = 8.0;
var
  B: TBitmap;
  FN: String;
  Dims: TPointF;
begin
  FN:= TPath.Combine(TPath.GetPicturesPath, 'Test.png');

  Dims:= FSignature.MaxDims(SAVE_SCALE);

  B:= TBitmap.Create(Trunc(Dims.X), Trunc(Dims.Y));
  try
    FSignature.PaintTo(B.Canvas, SAVE_SCALE);
    B.SaveToFile(FN);
  finally
    FreeAndNil(B);
  end;
end;

procedure TForm1.imgPreviewPaint(Sender: TObject; Canvas: TCanvas;
  const ARect: TRectF);
begin
  FSignature.PaintTo(Canvas, 0.4);
end;

procedure TForm1.SignatureChange(Sender: TObject);
begin
  imgPreview.Repaint;
end;

procedure TForm1.PenDown(Sender: TObject; Point: TVectorPoint);
begin
  {$IFNDEF MACOS}
  Memo1.Lines.Add('Pen Down:  '+FormatFloat('0', Point.CurPos.X)+' x '+
    FormatFloat('0', Point.CurPos.Y));
  {$ENDIF}
end;

procedure TForm1.PenMove(Sender: TObject; Point: TVectorPoint);
begin
  {$IFNDEF MACOS}
  Memo1.Lines.Add('Pen Move:  '+FormatFloat('0', Point.CurPos.X)+' x '+
    FormatFloat('0', Point.CurPos.Y));
  {$ENDIF}
end;

procedure TForm1.PenUp(Sender: TObject; Point: TVectorPoint);
begin
  {$IFNDEF MACOS}
  Memo1.Lines.Add('Pen Up:    '+FormatFloat('0', Point.CurPos.X)+' x '+
    FormatFloat('0', Point.CurPos.Y));
  {$ENDIF}
end;

procedure TForm1.SignatureClear(Sender: TObject);
begin
  {$IFNDEF MACOS}
  Memo1.Lines.Clear;
  {$ENDIF}
end;

end.

Test Form: uMain.fmx

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Signature Capture Test'
  ClientHeight = 600
  ClientWidth = 456
  Position = ScreenCenter
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Orientations = [Portrait]
  FormFactor.Devices = [Desktop]
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  DesignerMasterStyle = 0
  object Layout1: TLayout
    Align = Client
    Size.Width = 456.000000000000000000
    Size.Height = 600.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 0
    object imgPreview: TRectangle
      Align = Top
      Margins.Left = 5.000000000000000000
      Margins.Top = 5.000000000000000000
      Margins.Right = 5.000000000000000000
      Margins.Bottom = 5.000000000000000000
      Position.X = 5.000000000000000000
      Position.Y = 5.000000000000000000
      Size.Width = 446.000000000000000000
      Size.Height = 84.000000000000000000
      Size.PlatformDefault = False
      OnClick = imgPreviewClick
      OnPaint = imgPreviewPaint
    end
    object Panel1: TPanel
      Align = Client
      Size.Width = 456.000000000000000000
      Size.Height = 506.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 2
      object Memo1: TMemo
        Touch.InteractiveGestures = [Pan, LongTap, DoubleTap]
        DataDetectorTypes = []
        ReadOnly = True
        StyledSettings = [Size, Style, FontColor]
        TextSettings.Font.Family = 'Consolas'
        Align = Top
        Anchors = [akLeft, akTop, akRight, akBottom]
        Margins.Left = 8.000000000000000000
        Margins.Right = 8.000000000000000000
        Margins.Bottom = 8.000000000000000000
        Position.X = 8.000000000000000000
        Size.Width = 440.000000000000000000
        Size.Height = 466.000000000000000000
        Size.PlatformDefault = False
        TabOrder = 2
        Viewport.Width = 436.000000000000000000
        Viewport.Height = 462.000000000000000000
      end
      object cmdClear: TButton
        Anchors = [akLeft, akBottom]
        Position.X = 8.000000000000000000
        Position.Y = 470.000000000000000000
        Size.Width = 97.000000000000000000
        Size.Height = 33.000000000000000000
        Size.PlatformDefault = False
        TabOrder = 1
        Text = 'Clear'
        OnClick = cmdClearClick
      end
    end
  end
end

Use my code: http://www.fmxexpress.com/cross-platform-firemonkey-drawing-app-demo/ I paid a long time Delphi graphics developer and he figured out how to make it happen on touch screens. — FMXExpress, Aug 02 '15 at 02:40
@FMXExpress Looks interesting, and I'm sure the solution to my particular issue is hidden deep in there. Just quite a bit more than I was bargaining for. — Jerry Dodge, Aug 02 '15 at 04:36
@FMXExpress Also, just a tip of advise for that particular article. Bugs are common, and it's okay to say you have them. Just don't focus half of the article explaining the bugs. That discourages people from wanting to use it. Just at the very end, mention "By the way, there's a bug which...." etc. Most of it should be listing the features straight-forward, as well as convincing readers why they should continue. — Jerry Dodge, Aug 02 '15 at 05:11
The mentioned bugs are in Delphi XE5 not with the solution. The ellipse bug is fixed in XE8. The OnMouseMove event in the custom TPaintBox is the pen code you want. — FMXExpress, Aug 02 '15 at 05:20
@FMXExpress Gotcha, wasn't looking too thoroughly. I wouldn't need the ellipse tool anyway though, just a series of lines. What exactly makes the `OnMouseMove` of yours different which would solve this issue of `OnMouseUp` firing? — Jerry Dodge, Aug 02 '15 at 05:29
I mean, I've already encapsulated this inside of a control. Doing it on a third-party paintbox seems a bit overhaul and moving backwards in this situation. If you can point me to the exact difference which would make gestures more adequately handled than how I currently am, that's what I'm looking for. — Jerry Dodge, Aug 02 '15 at 06:18
I have no idea. I do know the problem you are talking about because I ran into that same problem and the code there was the fix. Whatever adjustments it is making to the From and To point in the IFDEF POSIX section before (and after) doing DrawLine makes it work. If I had code that would just plug into your code as the answer I would post it as the answer instead of a comment :P Alternately, you could plug into the Delphi multitouch support which is not through OnMouseMove but through OnTouch. — FMXExpress, Aug 02 '15 at 06:20
@JerryDodge I didn't downvote but I know what you mean, those mystery downvoters should give some kind of feedback as to why they downvoted a question or answer, at least then if it's for a genuine reason you can take a step back and look to improve on it. There seems to be more users willing to downvote then upvote on here, I notice quite a few valid questions a day that don't really merit a downvote and this is one of them. Yet I saw a question asking does Delphi work on Windows 10 and it get's upvoted when to me that is poor research, try it yourself and see or ask in a comment elsewhere. — Craig, Aug 04 '15 at 09:09
@FMXExpress Looking back, I still never had a solution for this, and the overall project it was for got put on hold. Looks like still no answers, but plenty of views from people looking for the answer. Wonder how many came here, yanked my code, fixed it and never posted an answer? — Jerry Dodge, Feb 05 '20 at 23:48

score 0 · Answer 1 · answered Feb 19 '22 at 01:11

The perfect solution is to apply a "rounding sharp corners" effect to the signature path, and render it using antialiasing. It is possible to do this easily using the Skia4Delphi library: https://github.com/skia4delphi/skia4delphi

Even in the library demo itself there is this example. Look:

Capturing signature very sketchy on touch screen

1 Answers1

Linked