fix(sync): QR plus court (adresse du depot, sans sur-echappement) + TRY_HARDER au decodage

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
This commit is contained in:
r-zakarya
2026-09-17 18:48:04 +01:00
parent dd9fd62dcb
commit 23967ddfca
2 changed files with 64 additions and 7 deletions
+47 -5
View File
@@ -348,10 +348,13 @@ type
FScanLay: TLayout;
FScanImg: TImage;
FCam: TCameraComponent;
FScanLbl: TLabel;
FScanWatch: TTimer;
procedure StartScan;
procedure BeginScan;
procedure StopScan;
procedure DoCancelScan(Sender: TObject);
procedure OnScanWatch(Sender: TObject);
procedure OnCamFrame(Sender: TObject; const ATime: TMediaTime);
function ApplySyncLink(const ALink: string): Boolean;
{$IFDEF ANDROID}
@@ -397,7 +400,7 @@ uses
PMA.Crypto, PMA.SyncClient, PMA.Store, PMA.Biometric, PMA.Totp,
PMA.ScreenGuard, PMA.Clipboard, PMA.Theme, PMA.WebUI, PMA.VaultPatch,
PMA.SaveFile, PMA.Favicon, System.JSON, System.Permissions,
ZXing.ScanManager, ZXing.BarcodeFormat, ZXing.ReadResult
ZXing.ScanManager, ZXing.BarcodeFormat, ZXing.ReadResult, ZXing.DecodeHintType
{$IFDEF ANDROID}
, Androidapi.JNI.GraphicsContentViewText, Androidapi.JNI.JavaTypes,
Androidapi.Helpers, FMX.Platform.Android, Androidapi.JNI.Os
@@ -3290,7 +3293,15 @@ begin
LLbl.TextSettings.FontColor := TAlphaColors.White;
LLbl.TextSettings.Font.Size := 16;
LLbl.TextSettings.HorzAlign := TTextAlign.Center;
LLbl.Text := 'Point the camera at the QR shown on the PC';
LLbl.WordWrap := True;
FScanLbl := LLbl;
// AUCUNE IMAGE = CAMERA TENUE AILLEURS. Ouverte par l'appareil photo du
// systeme, meme en arriere-plan, elle ne nous est pas donnee - et sans ce
// guet l'ecran restait noir sans un mot.
FScanWatch := TTimer.Create(Self);
FScanWatch.Enabled := False;
FScanWatch.Interval := 3000;
FScanWatch.OnTimer := OnScanWatch;
LBtn := TButton.Create(FScanLay);
LBtn.Parent := FScanLay;
LBtn.Align := TAlignLayout.Bottom;
@@ -3321,7 +3332,9 @@ begin
except
// Pas d'autofocus continu : l'image restera nette a bonne distance.
end;
FScanLbl.Text := 'Point the camera at the QR shown on the PC';
FCam.Active := True;
FScanWatch.Enabled := True;
Log('QR scan started');
end;
@@ -3329,6 +3342,7 @@ procedure TForm8.StopScan;
begin
if not FScanning then Exit;
FScanning := False;
if FScanWatch <> nil then FScanWatch.Enabled := False;
if FCam <> nil then FCam.Active := False;
if FScanLay <> nil then FScanLay.Visible := False;
FLayWeb.Visible := True;
@@ -3339,6 +3353,16 @@ begin
StopScan;
end;
procedure TForm8.OnScanWatch(Sender: TObject);
begin
FScanWatch.Enabled := False;
if FScanning and (FScanFrame = 0) then
begin
FScanLbl.Text := 'Camera busy - close the camera app, then Cancel and scan again';
Log('QR scan: no camera frame after 3 s');
end;
end;
/// Une image sur quatre part au decodage, jamais deux a la fois : ZXing prend
/// quelques dizaines de ms, et empiler les images figerait l'apercu.
procedure TForm8.OnCamFrame(Sender: TObject; const ATime: TMediaTime);
@@ -3360,17 +3384,30 @@ begin
var
LMgr: TScanManager;
LRes: TReadResult;
LText: string;
LText, LDiag: string;
LHints: TDictionary<TDecodeHintType, TObject>;
LW, LH: Integer;
begin
LText := '';
LDiag := '';
LRes := nil;
LMgr := TScanManager.Create(TBarcodeFormat.QR_CODE, nil);
LW := LBmp.Width;
LH := LBmp.Height;
// TRY_HARDER : le chercheur de motifs balaie chaque ligne au lieu
// d'en sauter - indispensable pour un QR photographie sur un ecran.
LHints := TDictionary<TDecodeHintType, TObject>.Create;
LHints.Add(TDecodeHintType.TRY_HARDER, nil);
LMgr := TScanManager.Create(TBarcodeFormat.QR_CODE, LHints); // libere les indices
try
try
LRes := LMgr.Scan(LBmp);
if LRes <> nil then LText := LRes.Text;
except
LText := '';
on E: Exception do
begin
LText := '';
LDiag := E.ClassName + ': ' + E.Message;
end;
end;
finally
LRes.Free;
@@ -3381,6 +3418,11 @@ begin
procedure
begin
FScanBusy := False;
// DIAG scan (temporaire) : les premiers essais, puis un sur vingt.
if (FScanFrame <= 40) or (FScanFrame mod 80 = 0) then
Log(Format('QR scan frame %d: %dx%d, %s', [FScanFrame, LW, LH,
IfThen(LDiag <> '', LDiag,
IfThen(LText = '', 'nothing found', 'read ' + IntToStr(Length(LText)) + ' chars'))]));
if (not FScanning) or (LText = '') then Exit;
if StartsText('pmserver://sync?', LText) then
begin