qr/qr.code.fmx.pas

//Copyright (c) 2019 by Jason Southwell
//
//Permission is hereby granted, free of charge, to any person obtaining a copy
//of this software and associated documentation files (the "Software"), to deal
//in the Software without restriction, including without limitation the rights
//to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
//copies of the Software, and to permit persons to whom the Software is
//furnished to do so, subject to the following conditions:
//
//The above copyright notice and this permission notice shall be included in all
//copies or substantial portions of the Software.
//
//THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
//IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
//FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
//AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
//LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
//OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
//SOFTWARE.

unit qr.code.fmx;

interface

uses
  System.SysUtils, System.Classes, FMX.Graphics, qr.code;

type
  TQRBitmap = class(TBitmap)
  private
    FQR : TQRCode;
    FShowBorder: boolean;
    FShowModuleGrid: boolean;
    function GetData: TArray<Byte>;
    function GetECL: TErrorCorrectionLevel;
    function GetMask: TMask;
    function GetText: string;
    function GetVersion: TVersion;
    procedure SetData(const Value: TArray<Byte>);
    procedure SetECL(const Value: TErrorCorrectionLevel);
    procedure SetMask(const Value: TMask);
    procedure SetText(const Value: string);
    procedure SetVersion(const Value: TVersion);
    procedure SetShowBorder(const Value: boolean);
    procedure SetShowModuleGrid(const Value: boolean);
  public
    constructor Create(AText : string; AWidth, AHeight : Single); overload;
    constructor Create(AText : string); overload;
    constructor Create(AText : string; APixelsPerModule : integer); overload;
    constructor Create(AData : TArray<Byte>; AWidth, AHeight : Single); overload;
    constructor Create(AData : TArray<Byte>); overload;
    constructor Create(AData : TArray<Byte>; APixelsPerModule : integer); overload;
    constructor Create; overload; override;
    destructor Destroy; override;

    procedure BeginUpdate;
    procedure EndUpdate;

    property Text : string read GetText write SetText;
    property Data : TArray<Byte> read GetData write SetData;

    property Version : TVersion read GetVersion write SetVersion;
    property ECL : TErrorCorrectionLevel read GetECL write SetECL;
    property Mask : TMask read GetMask write SetMask;

    property ShowModuleGrid : boolean read FShowModuleGrid write SetShowModuleGrid;
    property ShowBorder : boolean read FShowBorder write SetShowBorder;
  end;

implementation

uses System.Math, System.Types, System.UITypes;

{ TQRCodeBitmap }

procedure TQRBitmap.BeginUpdate;
begin
  FQR.BeginUpdate;
end;

constructor TQRBitmap.Create;
begin
  inherited Create;
  FQR := TQRCode.Create;
  FQR.OnPaint :=
    procedure(Width, Height : Integer; BlackRects : TArray<TRect>)
    var
      R : TRect;
      x, y : integer;
    begin
      Self.Width := Width;
      Self.Height := Height;

      Self.Canvas.BeginScene;
      try
        Self.Canvas.Fill.Color := TAlphaColorRec.White;
        Self.Canvas.Stroke.Color := TAlphaColorRec.White;
        Self.Canvas.FillRect(TRect.Create(0,0,Self.Width, Self.Height), 0, 0, [],1);

        Self.Canvas.Fill.Color := TAlphaColorRec.Black;
        Self.Canvas.Stroke.Color := TAlphaColorRec.Black;

        for R in BlackRects do
        begin
          Self.Canvas.FillRect(R, 0, 0, [], 1);
        end;

        if FShowModuleGrid then
        begin
          Self.Canvas.Stroke.Color := TAlphaColorRec.LtGray;
          Self.Canvas.Stroke.Dash := TStrokeDash.Dot;
          for x := 0 to Self.Width -1 do
            if x mod FQR.PixelsPerModule = 0 then
            begin
              Self.Canvas.DrawLine(TPointF.Create(x,0), TPointF.Create(x,Self.Height-1),1);
            end;
          for y := 0 to Self.Height-1 do
          begin
            if y mod FQR.PixelsPerModule = 0 then
            begin
              Self.Canvas.DrawLine(TPointF.Create(0,y), TPointF.Create(Self.Height-1, y), 1);
            end;
          end;
        end;

        if FShowBorder then
        begin
          Self.Canvas.Fill.Color := TAlphaColorRec.Black;
          Self.Canvas.Stroke.Color := TAlphaColorRec.Black;
          Self.Canvas.Stroke.Dash := TStrokeDash.Solid;
          Self.Canvas.DrawRect(TRect.Create(0,0,Self.Width, Self.Height),0,0,[],1);
        end;
      finally
        Self.Canvas.EndScene;
      end;

    end;
end;

constructor TQRBitmap.Create(AText: string; APixelsPerModule: integer);
begin
  Create;
  FQR.BeginUpdate;
  try
    FQR.Text := AText;
    FQR.PixelsPerModule := APixelsPerModule;
  finally
    FQR.EndUpdate;
  end;
end;

constructor TQRBitmap.Create(AData: TArray<Byte>; AWidth, AHeight: Single);
begin
  Create;
  FQR.BeginUpdate;
  try
    FQR.Data := AData;
    FQR.RenderSize := Round(Min(AWidth, AHeight));
  finally
    FQR.EndUpdate;
  end;
end;

constructor TQRBitmap.Create(AData: TArray<Byte>; APixelsPerModule: integer);
begin
  Create;
  FQR.BeginUpdate;
  try
    FQR.Data := AData;
    FQR.PixelsPerModule := APixelsPerModule;
  finally
    FQR.EndUpdate;
  end;
end;

constructor TQRBitmap.Create(AData: TArray<Byte>);
begin
  Create;
  FQR.Data := AData;
end;

constructor TQRBitmap.Create(AText: string);
begin
  Create;
  FQR.Text := AText;
end;

constructor TQRBitmap.Create(AText: string; AWidth, AHeight: Single);
begin
  Create;
  FQR.BeginUpdate;
  try
    FQR.Text := AText;
    FQR.RenderSize := Round(Min(AWidth, AHeight));
  finally
    FQR.EndUpdate;
  end;
end;

destructor TQRBitmap.Destroy;
begin
  FQR.Free;
  inherited;
end;

procedure TQRBitmap.EndUpdate;
begin
  FQR.EndUpdate;
end;

function TQRBitmap.GetData: TArray<Byte>;
begin
  Result := FQR.Data;
end;

function TQRBitmap.GetECL: TErrorCorrectionLevel;
begin
  Result := FQR.ECL;
end;

function TQRBitmap.GetMask: TMask;
begin
  Result := FQR.Mask;
end;

function TQRBitmap.GetText: string;
begin
  Result := FQR.Text;
end;

function TQRBitmap.GetVersion: TVersion;
begin
  Result := FQR.Version;
end;

procedure TQRBitmap.SetData(const Value: TArray<Byte>);
begin
  FQR.Data := Value;
end;

procedure TQRBitmap.SetECL(const Value: TErrorCorrectionLevel);
begin
  FQR.ECL := Value;
end;

procedure TQRBitmap.SetMask(const Value: TMask);
begin
  FQR.Mask := Value;
end;

procedure TQRBitmap.SetShowBorder(const Value: boolean);
begin
  FShowBorder := Value;
  FQR.Redraw;
end;

procedure TQRBitmap.SetShowModuleGrid(const Value: boolean);
begin
  FShowModuleGrid := Value;
  FQR.Redraw;
end;

procedure TQRBitmap.SetText(const Value: string);
begin
  FQR.Text := Value;
end;

procedure TQRBitmap.SetVersion(const Value: TVersion);
begin
  FQR.Version := Value;
end;

end.