QR-Code scannen

[DaCoda]

Ja, Delphi 12.2

Ich habe nun mal ein Demo in ein neues Projekt kopiert, funktioniert "fast". Nur QR-Code liest er nicht
Manche Barcodes aber schon (?)

Source:

Code:

unit MainForm;

interface

uses
  System.SysUtils,
  System.Types,
  System.UITypes,
  System.Classes,
  System.Variants,
  System.Math.Vectors,
  System.Actions,
  System.Threading,
  System.Permissions,

  FMX.Types,
  FMX.Controls,
  FMX.Forms,
  FMX.Graphics,
  FMX.Dialogs,
  FMX.Objects,
  FMX.StdCtrls,
  FMX.Media,
  FMX.Platform,
  FMX.MultiView,
  FMX.ListView.Types,
  FMX.ListView,
  FMX.Layouts,
  FMX.ActnList,
  FMX.TabControl,
  FMX.ListBox,
  FMX.Controls.Presentation,
  FMX.ScrollBox,
  FMX.Memo,
  FMX.Memo.Types,
  FMX.Controls3D,

  ZXing.BarcodeFormat,
  ZXing.ReadResult,
  ZXing.ScanManager;

type
  TfrmMain = class(TForm)
    Rectangle1: TRectangle;
    Camera: TCameraComponent;
    btnStartStop: TButton;
    lblScanStatus: TLabel;
    Memo1: TMemo;
    imgCamera: TImage;
    procedure btnStartStopClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CameraSampleBufferReady(Sender: TObject;
      const ATime: TMediaTime);
  private
  { Private declarations }
    fPermissionCamera: string;
    fScanInProgress: Boolean;
    fFrameTake: Integer;
    fScanBitmap: TBitmap;

    procedure ParseImage();
{$IF CompilerVersion >= 35.0}
    // after Delphi 11 Alexandria
    procedure CameraPermissionRequestResult(Sender: TObject;
      const APermissions: TClassicStringDynArray;
      const AGrantResults: TClassicPermissionStatusDynArray);
    procedure ExplainReason(Sender: TObject; const APermissions: TClassicStringDynArray;
      const APostRationaleProc: TProc);
{$ELSE}
    // before Delphi 11 Alexandria
    procedure CameraPermissionRequestResult(Sender: TObject;
      const APermissions: TArray<string>;
      const AGrantResults: TArray<TPermissionStatus>);
    procedure ExplainReason(Sender: TObject; const APermissions: TArray<string>;
      const APostRationaleProc: TProc);
{$ENDIF}

  public

  end;

var
  frmMain: TfrmMain;

implementation

{$R *.fmx}
{$R *.NmXhdpiPh.fmx ANDROID}
{$R *.LgXhdpiPh.fmx ANDROID}

uses
{$IFDEF ANDROID}
  Androidapi.Helpers,
  Androidapi.JNI.JavaTypes,
  Androidapi.JNI.Os,
{$ENDIF}
  FMX.DialogService;

procedure TfrmMain.btnStartStopClick(Sender: TObject);
begin
  if btnStartStop.Tag = 0 then begin
    PermissionsService.RequestPermissions([fPermissionCamera], CameraPermissionRequestResult, ExplainReason);

    btnStartStop.Text := 'Stop';
    btnStartStop.Tag := 1;
  end else begin
    Camera.Active := False;

    btnStartStop.Text := 'Start';
    btnStartStop.Tag := 0;
  end;

end;

procedure TfrmMain.CameraSampleBufferReady(Sender: TObject; const ATime: TMediaTime);
begin
  TThread.Synchronize(TThread.CurrentThread,
  procedure
  begin
    Camera.SampleBufferToBitmap(imgCamera.Bitmap, True);

    if (fScanInProgress) then
    begin
      exit;
    end;

    { This code will take every 4 frame. }
    inc(fFrameTake);
    if (fFrameTake mod 4 <> 0) then
    begin
      exit;
    end;

    if Assigned(fScanBitmap) then
      FreeAndNil(fScanBitmap);

    fScanBitmap := TBitmap.Create();
    fScanBitmap.Assign(imgCamera.Bitmap);

    ParseImage();
  end);
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
  AppEventSvc: IFMXApplicationEventService;
begin
  lblScanStatus.Text := '';
  fFrameTake := 0;
  fScanBitmap := nil;

{$IFDEF ANDROID}
  fPermissionCamera := JStringToString(TJManifest_permission.JavaClass.CAMERA);
{$ENDIF}
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
    Camera.Active := False;
  if Assigned(fScanBitmap) then
    FreeAndNil(fScanBitmap);
end;

{$IF CompilerVersion >= 35.0}
    // after Delphi 11 Alexandria
procedure TfrmMain.CameraPermissionRequestResult(Sender: TObject;
  const APermissions: TClassicStringDynArray;
  const AGrantResults: TClassicPermissionStatusDynArray);

{$ELSE}
    // before Delphi 11 Alexandria
procedure TMainForm.CameraPermissionRequestResult(Sender: TObject;
  const APermissions: TArray<string>;
  const AGrantResults: TArray<TPermissionStatus>);
{$ENDIF}
begin
  if (Length(AGrantResults) = 1) and
  (AGrantResults[0] = TPermissionStatus.Granted) then begin
    Camera.Active := false;
    Camera.Quality := FMX.Media.TVideoCaptureQuality.MediumQuality;
    Camera.Kind := FMX.Media.TCameraKind.BackCamera;
    Camera.FocusMode := FMX.Media.TFocusMode.ContinuousAutoFocus;
    Camera.Active := True;
    lblScanStatus.Text := '';
    Memo1.Lines.Clear;
  end else
    TDialogService.ShowMessage('Cannot scan for barcodes because the required permissions is not granted');
end;

{$IF CompilerVersion >= 35.0}
    // after Delphi 11 Alexandria
procedure TfrmMain.ExplainReason(Sender: TObject;
  const APermissions: TClassicStringDynArray; const APostRationaleProc: TProc);

{$ELSE}
    // before Delphi 11 Alexandria
procedure TMainForm.ExplainReason(Sender: TObject;
  const APermissions: TArray<string>; const APostRationaleProc: TProc);
{$ENDIF}
begin
  TDialogService.ShowMessage('The app needs to access the camera to scan codes ...', procedure(const AResult: TModalResult)
    begin
      APostRationaleProc;
    end);
end;

procedure TfrmMain.ParseImage();
begin

  TThread.CreateAnonymousThread(
    procedure
    var
      ReadResult: TReadResult;
      ScanManager: TScanManager;

    begin
      fScanInProgress := True;
      ScanManager := TScanManager.Create(TBarcodeFormat.Auto, nil);

      try

        try
          ReadResult := ScanManager.Scan(fScanBitmap);
        except
          on E: Exception do
          begin
            TThread.Synchronize(TThread.CurrentThread,
              procedure
              begin
                lblScanStatus.Text := E.Message;
              end);
            exit;
          end;
        end;

        TThread.Synchronize(TThread.CurrentThread,
          procedure
          begin

            if (Length(lblScanStatus.Text) > 10) then
            begin
              lblScanStatus.Text := '*';
            end;

            lblScanStatus.Text := lblScanStatus.Text + '*';
            if (ReadResult <> nil) then
            begin
              Memo1.Lines.Insert(0, ReadResult.Text);
            end;

          end);

      finally
        if ReadResult <> nil then
          FreeAndNil(ReadResult);

        ScanManager.Free;
        fScanInProgress := false;
      end;

    end).Start();

end;

end.