Capturing signature very sketchy on touch screen

2019-07-15 04:20发布

站内文章 / iOS
27 0 0

问题:

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
标签： ios delphi drawing firemonkey delphi-xe8
举报

收藏的人(0)

Ta的文章 更多文章
登录 后发表评论
0条评论
还没有人评论过~