qr/demos/vcl/MainForm.pas

unit MainForm;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Generics.Collections, System.UITypes,
  Vcl.ExtCtrls, qr.code, Vcl.ComCtrls;

{$SCOPEDENUMS ON}

type
  TfrmQRMain = class(TForm)
    txtData: TEdit;
    cbECL: TComboBox;
    imgQR: TImage;
    txtWidth: TEdit;
    chkGrid: TCheckBox;
    txtDetails: TMemo;
    cbMask: TComboBox;
    cbVersion: TComboBox;
    procedure txtDataChange(Sender: TObject);
  private
    FQR : TQRCode;
  protected
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
  end;

var
  frmQRMain: TfrmQRMain;

implementation

{$R *.dfm}


procedure TfrmQRMain.BeforeDestruction;
begin
  inherited;
  FQR.Free;
end;

procedure TfrmQRMain.AfterConstruction;
begin
  inherited;
  cbECL.ItemIndex := 0;
  cbMask.ItemIndex := 8;
  cbVersion.ItemIndex := 0;
  FQR := TQRCode.Create;
  FQR.OnPaint :=
    procedure(Width, Height : integer; BlackRects : TArray<TRect>)
      function ECLToString : string;
      begin
        case FQR.ECLInUse of
          TErrorCorrectionLevel.Auto:
            Result := 'ERROR (Auto)';
          TErrorCorrectionLevel.Low:
            Result := 'Low';
          TErrorCorrectionLevel.Medium:
            Result := 'Medium';
          TErrorCorrectionLevel.Quartile:
            Result := 'Quartile';
          TErrorCorrectionLevel.High:
            Result := 'High';
        end;
      end;
    var
      bmp : TBitmap;
      R : TRect;
      x, y : integer;
      i: Integer;
      s, s2 : string;
      b : Byte;
    begin
      txtDetails.Lines.BeginUpdate;
      try
        txtDetails.Lines.Clear;
        txtDetails.Lines.Add('Version: '+Integer(FQR.VersionInUse).ToString);
        txtDetails.Lines.Add('ECL: '+ECLToString);
        txtDetails.Lines.Add('Module Size: '+FQR.Size.ToString+' at '+FQR.PixelsPerModule.ToString+' pixels');
        txtDetails.Lines.Add('Mask: '+Integer(FQR.MaskInUse).ToString);
        txtDetails.Lines.Add('');
        for i := 0 to 7 do
        begin
          txtDetails.Lines.Add('Penalty Score for Mask '+i.ToString);
          txtDetails.Lines.Add('  1 = '+FQR.PenaltyScores[i][0].ToString);
          txtDetails.Lines.Add('  2 = '+FQR.PenaltyScores[i][1].ToString);
          txtDetails.Lines.Add('  3 = '+FQR.PenaltyScores[i][2].ToString);
          txtDetails.Lines.Add('  4 = '+FQR.PenaltyScores[i][3].ToString);
          txtDetails.Lines.Add('  T = '+(FQR.PenaltyScores[i][0]+FQR.PenaltyScores[i][1]+FQR.PenaltyScores[i][2]+FQR.PenaltyScores[i][3]).ToString);
          txtDetails.Lines.Add('');
        end;
        txtDetails.Lines.Add('Bits:');
        txtDetails.Lines.Add(FQR.DataBits);
        txtDetails.Lines.Add('');
        txtDetails.Lines.Add('Codewords: ');
        s := '';
        s2 := '';
        for b in FQR.Codewords do
        begin
          s := s+', '+b.ToString;
          s2 := s2+', '+IntToHex(b,2);
        end;
        Delete(s,1,2);
        Delete(s2,1,2);
        txtDetails.Lines.Add(s);
        txtDetails.Lines.Add(s2);
      finally
        txtDetails.Lines.EndUpdate;
      end;
      bmp := TBitmap.Create;
      try
        bmp.Width := Width;
        bmp.Height := Height;

        bmp.Canvas.Lock;
        try
          bmp.Canvas.Brush.Color := clWhite;
          bmp.Canvas.Pen.Color := clWhite;
          bmp.Canvas.FillRect(TRect.Create(0,0,bmp.Width, bmp.Height));

          bmp.Canvas.Brush.Color := clBlack;
          bmp.Canvas.Pen.Color := clBlack;

          for R in BlackRects do
          begin
            bmp.Canvas.FillRect(R);
          end;

          if chkGrid.Checked then
          begin
            bmp.Canvas.Pen.Color := clLtGray;
            bmp.Canvas.Pen.Style := TPenStyle.psDot;
            for x := 0 to bmp.Width -1 do
              if x mod FQR.PixelsPerModule = 0 then
              begin
                bmp.Canvas.MoveTo(x,0);
                bmp.Canvas.LineTo(x,bmp.Height-1);
              end;
            for y := 0 to bmp.Height-1 do
            begin
              if y mod FQR.PixelsPerModule = 0 then
              begin
                bmp.Canvas.MoveTo(0,y);
                bmp.Canvas.LineTo(bmp.Height-1, y);
              end;
            end;
          end;

          bmp.Canvas.Brush.Color := clBlack;
          bmp.Canvas.Pen.Color := clBlack;

          bmp.Canvas.FrameRect(TRect.Create(0,0,bmp.Width, bmp.Height));
        finally
          bmp.Canvas.Unlock;
        end;

        imgQR.Picture.Graphic := bmp;
      finally
        bmp.Free;
      end;
    end;
  txtDataChange(Self);
end;

procedure TfrmQRMain.txtDataChange(Sender: TObject);
begin
  FQR.BeginUpdate;
  try
    FQR.ECL := TErrorCorrectionLevel(cbECL.ItemIndex);
    FQR.Text := txtData.Text;
    FQR.Mask := TMask(cbMask.ItemIndex);
    FQR.Version := TVersion(cbVersion.ItemIndex);
    FQR.RenderSize := StrToIntDef(txtWidth.Text, 300);
  finally
    FQR.EndUpdate;
  end;

end;

end.