从网上的js文件里转换的一个二维码生成程序，直接调用 make(）方法，返回TGPBitmap，之后用于显示或者保存文件都可以
/// <summary>
/// 二维码生成程序
/// 不要问我为什么这么多a,b,c,d,e无意义的变量
/// 通过查看别人的min.js文件翻译过来的，没累死算好了
/// <author>半桶水</author>
/// </summary>
unit uQrCode;
interface
uses System.Classes,System.Math,System.SysUtils,Winapi.Windows,Winapi.GDIPAPI,Winapi.GDIPOBJ,Winapi.GDIPUTIL;
type
TQRCode=class
private
const
RS_BLOCK_TABLE : array of array of Integer = [
[1, 26, 19],
[1, 26, 16],
[1, 26, 13],
[1, 26, 9],
[1, 44, 34],
[1, 44, 28],
[1, 44, 22],
[1, 44, 16],
[1, 70, 55],
[1, 70, 44],
[2, 35, 17],
[2, 35, 13],
[1, 100, 80],
[2, 50, 32],
[2, 50, 24],
[4, 25, 9],
[1, 134, 108],
[2, 67, 43],
[2, 33, 15, 2, 34, 16],
[2, 33, 11, 2, 34, 12],
[2, 86, 68],
[4, 43, 27],
[4, 43, 19],
[4, 43, 15],
[2, 98, 78],
[4, 49, 31],
[2, 32, 14, 4, 33, 15],
[4, 39, 13, 1, 40, 14],
[2, 121, 97],
[2, 60, 38, 2, 61, 39],
[4, 40, 18, 2, 41, 19],
[4, 40, 14, 2, 41, 15],
[2, 146, 116],
[3, 58, 36, 2, 59, 37],
[4, 36, 16, 4, 37, 17],
[4, 36, 12, 4, 37, 13],
[2, 86, 68, 2, 87, 69],
[4, 69, 43, 1, 70, 44],
[6, 43, 19, 2, 44, 20],
[6, 43, 15, 2, 44, 16],
[4, 101, 81],
[1, 80, 50, 4, 81, 51],
[4, 50, 22, 4, 51, 23],
[3, 36, 12, 8, 37, 13],
[2, 116, 92, 2, 117, 93],
[6, 58, 36, 2, 59, 37],
[4, 46, 20, 6, 47, 21],
[7, 42, 14, 4, 43, 15],
[4, 133, 107],
[8, 59, 37, 1, 60, 38],
[8, 44, 20, 4, 45, 21],
[12, 33, 11, 4, 34, 12],
[3, 145, 115, 1, 146, 116],
[4, 64, 40, 5, 65, 41],
[11, 36, 16, 5, 37, 17],
[11, 36, 12, 5, 37, 13],
[5, 109, 87, 1, 110, 88],
[5, 65, 41, 5, 66, 42],
[5, 54, 24, 7, 55, 25],
[11, 36, 12],
[5, 122, 98, 1, 123, 99],
[7, 73, 45, 3, 74, 46],
[15, 43, 19, 2, 44, 20],
[3, 45, 15, 13, 46, 16],
[1, 135, 107, 5, 136, 108],
[10, 74, 46, 1, 75, 47],
[1, 50, 22, 15, 51, 23],
[2, 42, 14, 17, 43, 15],
[5, 150, 120, 1, 151, 121],
[9, 69, 43, 4, 70, 44],
[17, 50, 22, 1, 51, 23],
[2, 42, 14, 19, 43, 15],
[3, 141, 113, 4, 142, 114],
[3, 70, 44, 11, 71, 45],
[17, 47, 21, 4, 48, 22],
[9, 39, 13, 16, 40, 14],
[3, 135, 107, 5, 136, 108],
[3, 67, 41, 13, 68, 42],
[15, 54, 24, 5, 55, 25],
[15, 43, 15, 10, 44, 16],
[4, 144, 116, 4, 145, 117],
[17, 68, 42],
[17, 50, 22, 6, 51, 23],
[19, 46, 16, 6, 47, 17],
[2, 139, 111, 7, 140, 112],
[17, 74, 46],
[7, 54, 24, 16, 55, 25],
[34, 37, 13],
[4, 151, 121, 5, 152, 122],
[4, 75, 47, 14, 76, 48],
[11, 54, 24, 14, 55, 25],
[16, 45, 15, 14, 46, 16],
[6, 147, 117, 4, 148, 118],
[6, 73, 45, 14, 74, 46],
[11, 54, 24, 16, 55, 25],
[30, 46, 16, 2, 47, 17],
[8, 132, 106, 4, 133, 107],
[8, 75, 47, 13, 76, 48],
[7, 54, 24, 22, 55, 25],
[22, 45, 15, 13, 46, 16],
[10, 142, 114, 2, 143, 115],
[19, 74, 46, 4, 75, 47],
[28, 50, 22, 6, 51, 23],
[33, 46, 16, 4, 47, 17],
[8, 152, 122, 4, 153, 123],
[22, 73, 45, 3, 74, 46],
[8, 53, 23, 26, 54, 24],
[12, 45, 15, 28, 46, 16],
[3, 147, 117, 10, 148, 118],
[3, 73, 45, 23, 74, 46],
[4, 54, 24, 31, 55, 25],
[11, 45, 15, 31, 46, 16],
[7, 146, 116, 7, 147, 117],
[21, 73, 45, 7, 74, 46],
[1, 53, 23, 37, 54, 24],
[19, 45, 15, 26, 46, 16],
[5, 145, 115, 10, 146, 116],
[19, 75, 47, 10, 76, 48],
[15, 54, 24, 25, 55, 25],
[23, 45, 15, 25, 46, 16],
[13, 145, 115, 3, 146, 116],
[2, 74, 46, 29, 75, 47],
[42, 54, 24, 1, 55, 25],
[23, 45, 15, 28, 46, 16],
[17, 145, 115],
[10, 74, 46, 23, 75, 47],
[10, 54, 24, 35, 55, 25],
[19, 45, 15, 35, 46, 16],
[17, 145, 115, 1, 146, 116],
[14, 74, 46, 21, 75, 47],
[29, 54, 24, 19, 55, 25],
[11, 45, 15, 46, 46, 16],
[13, 145, 115, 6, 146, 116],
[14, 74, 46, 23, 75, 47],
[44, 54, 24, 7, 55, 25],
[59, 46, 16, 1, 47, 17],
[12, 151, 121, 7, 152, 122],
[12, 75, 47, 26, 76, 48],
[39, 54, 24, 14, 55, 25],
[22, 45, 15, 41, 46, 16],
[6, 151, 121, 14, 152, 122],
[6, 75, 47, 34, 76, 48],
[46, 54, 24, 10, 55, 25],
[2, 45, 15, 64, 46, 16],
[17, 152, 122, 4, 153, 123],
[29, 74, 46, 14, 75, 47],
[49, 54, 24, 10, 55, 25],
[24, 45, 15, 46, 46, 16],
[4, 152, 122, 18, 153, 123],
[13, 74, 46, 32, 75, 47],
[48, 54, 24, 14, 55, 25],
[42, 45, 15, 32, 46, 16],
[20, 147, 117, 4, 148, 118],
[40, 75, 47, 7, 76, 48],
[43, 54, 24, 22, 55, 25],
[10, 45, 15, 67, 46, 16],
[19, 148, 118, 6, 149, 119],
[18, 75, 47, 31, 76, 48],
[34, 54, 24, 34, 55, 25],
[20, 45, 15, 61, 46, 16]
];
PATTERN_POSITION_TABLE: array of array of Integer= [
[],
[6, 18],
[6, 22],
[6, 26],
[6, 30],
[6, 34],
[6, 22, 38],
[6, 24, 42],
[6, 26, 46],
[6, 28, 50],
[6, 30, 54],
[6, 32, 58],
[6, 34, 62],
[6, 26, 46, 66],
[6, 26, 48, 70],
[6, 26, 50, 74],
[6, 30, 54, 78],
[6, 30, 56, 82],
[6, 30, 58, 86],
[6, 34, 62, 90],
[6, 28, 50, 72, 94],
[6, 26, 50, 74, 98],
[6, 30, 54, 78, 102],
[6, 28, 54, 80, 106],
[6, 32, 58, 84, 110],
[6, 30, 58, 86, 114],
[6, 34, 62, 90, 118],
[6, 26, 50, 74, 98, 122],
[6, 30, 54, 78, 102, 126],
[6, 26, 52, 78, 104, 130],
[6, 30, 56, 82, 108, 134],
[6, 34, 60, 86, 112, 138],
[6, 30, 58, 86, 114, 142],
[6, 34, 62, 90, 118, 146],
[6, 30, 54, 78, 102, 126, 150],
[6, 24, 50, 76, 102, 128, 154],
[6, 28, 54, 80, 106, 132, 158],
[6, 32, 58, 84, 110, 136, 162],
[6, 26, 54, 82, 110, 138, 166],
[6, 30, 58, 86, 114, 142, 170]
];
PATTERN000=0;
PATTERN001=1;
PATTERN010=2;
PATTERN011=3;
PATTERN100=4;
PATTERN101=5;
PATTERN110=6;
PATTERN111=7;
PAD0=236;
PAD1=17;
G15=1335;
G18=7973;
G15_MASK=21522;
private
type
TIntArr=array of Integer;
TDataRec=record
buff:array of Integer;
len:Integer;
end;
PPixelFour = ^TPixelFour;
TPixelFour = record
blue,green,red,Alpha: Byte;
procedure setBlank;
procedure setBlack;
end;
const
defaultWidth=256;
errorCorrectLevel=1;
function boolValue(b:Boolean):Integer;
protected
var
EXP_TABLE: array[0..255] of Integer;
LOG_TABLE: array[0..255] of Integer;
QrCodeBytes:TintArr;
typeNumber: Integer ;
modules:array of array of Integer;
moduleCount :Integer;
rsBlock:array of Integer;
totalDataCount :integer;
function MathShr(num:Integer;y:Byte):Integer;
procedure createExpTable;
function getCharByte(ACII:Integer):TIntArr;
procedure getUtf8Bytes(CodeStr:string);
function createData:TIntArr;
function createBytes(data:TdataRec):TIntArr;
function getNumArr(SArr:array of Integer; b:Integer):TIntArr;
procedure createQrcode(data:TIntArr);
procedure getRightType;
function CreateImg(width:Integer):TGPBitmap;
public
constructor Create(); overload;
destructor Destroy; override;
/// <summary>
/// <param name="width">图片的宽度，但并非实际宽度，会根据数据大小进行调整</param>
/// </summary>
function make(CodeStr:string; width:Integer=defaultWidth):TGPBitmap;
end;
implementation
{ TQRCode }
constructor TQRCode.Create();
begin
inherited;
createExpTable;
end;
destructor TQRCode.Destroy;
begin
Finalize(EXP_TABLE);
Finalize(LOG_TABLE);
inherited;
end;
procedure TQRCode.createExpTable;
var
I: Integer;
begin
for I := 0 to 7 do
EXP_TABLE[i]:=1 shl i;
for I := 8 to 255 do
EXP_TABLE[i]:= EXP_TABLE[i-4] xor EXP_TABLE[i-5] xor EXP_TABLE[i-6] xor EXP_TABLE[i-8];
for I := 0 to 254 do
LOG_TABLE[EXP_TABLE[i]]:=i;
end;
function TQRCode.make(CodeStr:string; width:Integer=defaultWidth):TGPBitmap;
begin
typeNumber:=-1 ;
moduleCount:=0;
totalDataCount :=-1;
getUtf8Bytes(CodeStr);
getRightType;
createQrcode(createData);
Result:=CreateImg(width);
SetLength(modules,0);
SetLength(rsBlock,0);
SetLength(QrCodeBytes,0);
SetLength(rsBlock,0);
end;
function TQRCode.CreateImg(width:Integer):TGPBitmap;
var
imgData:BitmapData;
img:TGPBitmap;
rect:TGPRect;
w,h:Integer;
p:PPixelFour;
i,j,n,t:Integer;
procedure fillRect(rect:TGPRect;isBlack:Boolean);
var
x,y,n:Integer;
begin
{$PointerMath On}
for x := rect.X to rect.X+rect.Width-1 do
for y := rect.Y to rect.Y+rect.Height-1 do
begin
n:=y*w+x;
if isBlack then p[n].setBlack
else p[n].setBlank;
end;
{$PointerMath Off}
end;
begin
t:=width div moduleCount;
if t<1 then
begin
t:=1;
width:=moduleCount;
end;
w:=t*moduleCount;
h:=w;
img:=TGPBitmap.Create(w,h);
rect:=makerect(0,0,w,h);
img.LockBits(rect,ImageLockModeWrite,PixelFormat32bppRGB,imgData);
try
p:=imgData.Scan0;
for I := 0 to moduleCount-1 do
for j := 0 to moduleCount-1 do
begin
rect:=MakeRect(i*t,j*t,t,t);
fillRect(rect,modules[i][j]=1);
end;
finally
img.UnlockBits(imgData);
end;
Result:=img;
// GetEncoderClsid('image/bmp', ImgGUID);
// img.Save('e:\2.jpg',imgGuid);
// img.Free;
end;
function TQRCode.MathShr(num:Integer;y:Byte):Integer;
asm
mov eax,num
mov cl,y
sar eax,cl
end;
procedure TQRCode.getRightType;
var
I,m,n ,d,f,g,h,j: Integer;
temArr:array of Integer;
begin
for I := 1 to 40 do
begin
m:= 4*(i-1)+errorCorrectLevel;
// SetLength(temArr,Length(RS_BLOCK_TABLE[m]));
// for j := 0 to Length(RS_BLOCK_TABLE[m])-1 do
// temArr[j]:= RS_BLOCK_TABLE[m][j];
SetLength(temArr,0);
Move(RS_BLOCK_TABLE[m],temArr,SizeOf(Integer));
m:=0;
while (m<Length(temArr)/3) do
begin
f:=temArr[3*m+0];
g:=temArr[3*m+2];
d:=g*f;
Inc(m);
end;
if i>9 then h:=2
else h:=1;
if (Length(QrCodeBytes)+h<d) or (i=40) then
begin
typeNumber:=i;
totalDataCount:=d;
// SetLength(rsBlock,Length(temArr));
// for j := 0 to Length(temArr)-1 do
// rsBlock[j]:=temArr[j];
SetLength(rsBlock,0);
Move(temArr,rsBlock,SizeOf(Integer));
Break;
end;
end;
end;
function TQRCode.boolValue(b: Boolean):Integer;
begin
if b then Result:=1
else Result:=-1;
end;
procedure TQRCode.createQrcode(data:TIntArr);
var
b,d:Integer;
a,lostPoint:Double;
temArr: array of array of Integer;
function getPatternPosition(a:Integer):TIntArr;
var
i:Integer;
begin
SetLength(result,Length(PATTERN_POSITION_TABLE[a-1]));
for I := 0 to Length(PATTERN_POSITION_TABLE[a-1])-1 do
Result[i]:=PATTERN_POSITION_TABLE[a-1][i];
// Move(PATTERN_POSITION_TABLE[a-1],Result,SizeOf(Integer));
end;
procedure setupTimingPattern;
var
a:Integer;
begin
for a := 8 to moduleCount-8 do
begin
if modules[a][6]=0 then
begin
modules[a][6]:= boolValue(a mod 2 =0);
end;
if modules[6][a]=0 then
begin
modules[6][a]:= boolValue(a mod 2=0);
end;
end;
end;
procedure setupPositionAdjustPattern;
var
a:TIntArr;
b,c,d,e,f,g:Integer;
aBool:Boolean;
begin
a:=getPatternPosition(typeNumber);
for b := 0 to Length(a)-1 do
begin
for c := 0 to Length(a)-1 do
begin
d:=a[b];
e:=a[c];
if modules[d][e]=0 then
begin
for f := -2 to 2 do
begin
for g := -2 to 2 do
begin
aBool:= (f=-2) or (f=2) or (g=-2) or (g=2) or ( (f=0) and (g=0) );
modules[d+f][e+g] := boolValue(aBool);
end;
end;
end;
end;
end;
end;
procedure setupPositionProbePattern(a,b:Integer);
var
c,d:Integer;
aBool:Boolean;
begin
for c := -1 to 7 do
begin
if ( (a+c>-1) and (moduleCount>a+c) ) then
begin
for d := -1 to 7 do
begin
if ( b+d>-1) and (moduleCount>b+d) then
begin
aBool:= ( (c>=0) and (c<=6) and ((d=0) or (d=6) ) )
or ( (d>=0) and (d<=6) and ( (c=0) or (c=6) ) )
or ( (c>=2) and (c<=4) and (d>=2) and (d<=4) );
modules[a+c][b+d]:=boolValue(aBool);
end;
end;
end;
end;
end;
function getBCHDigit(a:Integer):Integer;
begin
Result:=0;
while a<>0 do
begin
Inc(Result);
a:=MathShr(a,1);
// a:= a shr 1;
end;
end;
function getBCHTypeInfo(a:Integer):Integer;
var
b:Integer;
begin
b:=a shl 10;
while getBCHDigit(b)- getBCHDigit(G15)>=0 do
begin
b:= b xor ( G15 shl (getBCHDigit(b) - getBCHDigit(G15)));
end;
Result:= ( (a shl 10) or b) xor G15_MASK;
end;
procedure setupTypeInfo(a:Boolean;b:Integer);
var
c,d,e,f:Integer;
g:Boolean;
begin
c:=0 or b;
d:=getBCHTypeInfo(c);
for e := 0 to 14 do
begin
g:= ( not a) and ( (1 and (d shr e) ) =1) ;
if e<6 then
begin
modules[e][8]:= boolValue(g);
end else if e<8 then
begin
modules[e + 1][8] :=boolValue(g)
end else
begin
modules[moduleCount - 15 + e][8] :=boolValue(g);
end;
if e<8 then
begin
modules[8][moduleCount-e-1]:=boolValue(g);
end else if e<9 then
begin
modules[8][15-e]:=boolValue(g);
end else modules[8][15-e-1]:=boolValue(g);
end;
modules[moduleCount-8][8]:= boolValue(not a);
end;
function getBCHTypeNumber(a:Integer):Integer;
var
b:Integer;
begin
b:= a shl 12;
while getBCHDigit(b) - getBCHDigit(G18) >=0 do
begin
b:= b xor ( G18 shl (getBCHDigit(b)-getBCHDigit(G18)));
end;
end;
procedure setupTypeNumber(a:Boolean);
var
b,c:Integer;
d:Boolean;
begin
b:=getBCHTypeNumber(typeNumber);
for c := 0 to 17 do
begin
d:= (not a) and ( (1 and (b shr c) )=1 );
modules[c div 3][ (c mod 3) + moduleCount -8 -3]:= boolValue(d);
modules[ (c mod 3) + moduleCount -8 - 3][ c div 3]:= boolValue(d);
end;
end;
function getMask(a,b,c:Integer):Boolean;
begin
case a of
PATTERN000: result:=(b+c) mod 2 =0;
PATTERN001: result:= (b mod 2) = 0;
PATTERN010: Result := (c mod 3) =0;
PATTERN011: result:= (b+c) mod 3=0;
PATTERN100: Result:= ((b div 2) + (c div 3)) mod 2 = 0;
PATTERN101: result:= (b*c) mod 2 + (b*c) mod 3 =0;
PATTERN110: result:= ( (b*c) mod 2 + (b*c) mod 3) mod 2=0;
PATTERN111: result:= ( (b*c) mod 3 + (b+c) mod 2) mod 2=0;
else raise Exception.Create('bad maskPattern: '+a.ToString);
end;
end;
procedure mapData(a:TIntArr;b:Integer);
var
c,d,f,g,i:Integer;
j,k:Boolean;
e:Byte;
t1,t2:Integer;
begin
c:=-1;d:=moduleCount-1;e:=7;f:=0;g:=moduleCount-1;
while g>0 do
begin
if g=6 then Dec(g);
while True do
begin
for I := 0 to 1 do
begin
if modules[d][g-i]=0 then
begin
j:=False;
// if f<Length(a) then j:= ( 1 and ( a[f] shr e) ) =1;
if f<Length(a) then j:= ( 1 and MathShr( a[f] , e) ) =1;
k:=getMask(b,d,g-i);
if k then j:= not j;
modules[d][g-i]:=boolValue(j);
Dec(e);
//这里原来是 e=-1，因为改了e为byte型，当e=0的时候，再dec(e)，e就变成了256（$FF)
if e>7 then
begin
Inc(f);
e:=7;
end;
end;
end;
d:= d+c;
if (d<0) or (moduleCount<=d) then
begin
d:=d-c;
c:= -c;
Break;
end;
end;
g:=g-2;
end;
end;
function getLostPoint :Double;
var
b,d,e,f,h,j:Integer;
i,g:Boolean;
c,k:Double;
begin
b:=moduleCount;c:=0;d:=0;
for e := 0 to b-1 do
begin
f:=0;
g:= modules[e][0]=1;
for h := 0 to b-1 do
begin
i:= modules[e][h]=1;
if (b-6>h) and i and (modules[e][h+1]<>1) and (modules[e][h+2]=1)
and (modules[e][h+3]=1) and (modules[e][h+4]=1) and (modules[e][h+5]<>1) and (modules[e][h+6]=1) then
begin
if b-10>h then
begin
if (modules[e][h+7]=1) and (modules[e][h+8]=1) and (modules[e][h+9]=1) and (modules[e][h+10]=1) then
c:=c+40;
end else
begin
if (h>3) and (modules[e][h-1]=1) and (modules[e][h-2]=1) and (modules[e][h-3]=1) and (modules[e][h-4]=1) then
c:=c+40;
end;
end;
if (b-1>e) and (b-1>h) then
begin
j:=0;
if i then Inc(j);
if modules[e+1][h]=1 then Inc(j);
if modules[e][h+1]=1 then Inc(j);
if modules[e+1][h+1]=1 then Inc(j);
if (j=0) or (j=4) then c:=c+3;
end;
if i xor g then Inc(f)
else
begin
g:=i;
if (f>=5) then
c:= c+3+f-5;
f:=1;
end;
if i then Inc(d);
end;
end;
for h := 0 to b-1 do
begin
g:= modules[0][h]=1;
f:=0;
for e := 0 to b-1 do
begin
i:=modules[e][h]=1;
if (e<b-6) and i and (modules[e+1][h]<>1) and (modules[e+2][h]=1) and (modules[e+3][h]=1)
and (modules[e+4][h]=1) and (modules[e+5][h]<>1) and (modules[e+6][h]=1) then
begin
if e<b-10 then
begin
if (modules[e+7][h]=1) and (modules[e+8][h]=1) and (modules[e+9][h]=1) and (modules[e+10][h]=1) then
c:=c+40;
end else
begin
if (e>3) and (modules[e-1][h]=1) and (modules[e-2][h]=1) and (modules[e-3][h]=1) and (modules[e-4][h]=1) then
c:=c+40;
end;
end;
if g xor i then Inc(f)
else
begin
g:=i;
if f>=5 then c:=c+3+f-5;
f:=1;
end;
end;
end;
k:=Abs(100*d/b/b-50) /5;
Result:=c+10*k
end;
procedure makeImpl(a:Integer);
var
i:Integer;
begin
moduleCount:=4*typeNumber+17;
SetLength(modules,0);
SetLength(modules,moduleCount,moduleCount);
setupPositionProbePattern(0,0);
setupPositionProbePattern(moduleCount-7,0);
setupPositionProbePattern(0,moduleCount-7);
setupPositionAdjustPattern;
setupTimingPattern;
setupTypeInfo(True,a);
if typeNumber>=7 then setupTypeNumber(True);
mapData(data,a);
end;
var
i,j:Integer;
begin
a:=0;b:=0;
for d := 0 to 7 do
begin
makeImpl(d);
lostPoint:=getLostPoint;
if (d=0) or (a>lostPoint) then
begin
a:=lostPoint;
b:=d;
Finalize(temArr);
SetLength(temArr,moduleCount,moduleCount);
for I := 0 to moduleCount-1 do
for j := 0 to moduleCount-1 do
temArr[i][j]:=modules[i][j];
end;
end;
for I := 0 to moduleCount-1 do
for j := 0 to moduleCount-1 do
modules[i][j]:=temArr[i][j];
setupTypeInfo(False,b);
if typeNumber=7 then setupTypeNumber(False);
end;
function TQRCode.createData:TIntArr;
var
data:TDataRec;
b:Integer;
I: Integer;
procedure putBit(a:integer);
var
b:Integer;
begin
b:=data.len div 8;
if Length(data.buff)<=b then
begin
SetLength(data.buff,Length(data.buff)+1);
data.buff[Length(data.buff)-1]:=0;
end;
if a>0 then
begin
if Length(data.buff)<=b then SetLength(data.buff,b+1);
//data.buff[b]:= data.buff[b] or (128 shr (data.len mod 8));
data.buff[b]:= data.buff[b] or MathShr(128 , (data.len mod 8));
end;
data.len:= data.len+1;
end;
procedure put(a,b:Integer);
var
I: Integer;
begin
for I := 0 to b-1 do
putBit(1 and MathShr(a , ( b -i-1)));
//putBit(1 and (a shr ( b -i-1)));
end;
begin
data.len:=0;
if typeNumber>9 then b:=16
else b:=8;
put(4,4);
put(Length(QrCodeBytes),b);
for I := 0 to Length(QrCodeBytes)-1 do
begin
put(QrCodeBytes[i],8);
end;
if data.len+4 <=8*totalDataCount then put(0,4);
while (data.len mod 8<> 0) do
begin
putBit(0);
end;
while True do
begin
if data.len>= 8*totalDataCount then Break;
put(PAD0,8);
if data.len>= 8*totalDataCount then Break;
put(PAD1,8);
end;
Result:=createBytes(data);
end;
function TQRCode.createBytes(data: TDataRec):TIntArr;
var
b,c,e,i,j,k,l,m,r,p,q,v,x:Integer;
g:array of array[0..1] of Integer;
n,o:array of array of Integer;
s,t,u:TIntArr;
function glog(a:Integer):Integer;
begin
if (a<1) then raise Exception.Create('glog(' + a.ToString + ')');
Result:=LOG_TABLE[a];
end;
function gexp(a:Integer):Integer;
begin
while a<0 do a:=a+255;
while a>=256 do a:=a-255;
Result:=EXP_TABLE[a];
end;
function ArrMod(oldArr,newArr:TIntArr):TIntArr;
var
len1,len2,i,g,j:Integer;
temArr:TIntArr;
canDelete:Boolean;
begin
len1:=Length(oldArr);
len2:=Length(newArr);
if (len1-len2<0) then
begin
SetLength(Result,length(oldArr));
for I := 0 to len1 do
result[i]:=oldArr[i];
// Move(oldArr,Result,SizeOf(Integer));
exit;
end;
SetLength(temArr,len1);
// for I := 0 to len1-1 do
// temArr[i]:=oldArr[i];
Move(oldArr[0],temArr[0],SizeOf(Integer)*len1);
i:=SizeOf(oldArr);
while Length(temArr)>=len2 do
begin
g:=glog(temArr[0]) - glog(newArr[0]);
for I := 0 to len2-1 do
begin
temArr[i]:= temArr[i] xor gexp(glog(newArr[i])+g);
end;
while temArr[0]=0 do
begin
j:=Length(temArr);
// for I := 0 to Length(temArr)-2 do
// temArr[i]:=temArr[i+1];
Finalize(temArr[0]);
Move(temArr[1],temArr[0],SizeOf(Integer)*(Length(temArr)-1));
SetLength(temArr,j-1);
end;
end;
Result:=getNumArr(temArr,0) ;
end;
function multiply(oldArr,NewArr:TIntArr):TIntArr;
var
i,j:Integer;
temArr:array of Integer;
begin
SetLength(temArr,Length(oldArr)+Length(NewArr)-1);
for I := 0 to Length(oldArr)-1 do
begin
for j := 0 to Length(NewArr)-1 do
begin
temArr[i+j]:= temArr[i+j] xor (gexp(glog(oldArr[i]) + glog(newArr[j]) ) );
end;
end;
Result:=getNumArr(temArr,0);
end;
function getErrorCorrectPolynomial(a:Integer):TIntArr;
var
b:TIntArr;
temArr:TIntArr;
i:Integer;
begin
SetLength(temArr,1);
temArr[0]:=1;
b:=getNumArr(temArr,0);
for I := 0 to a-1 do
begin
SetLength(temArr,2);
temArr[0]:=1;
temArr[1]:=gexp(i);
temArr:=getNumArr(temArr,0);
b:=multiply(b,temArr);
end;
Result:=b;
end;
begin
i:=0;
while Length(rsBlock)/3>i do
begin
j:=rsBlock[3*i];
k:=rsBlock[3*i+1];
l:=rsBlock[3*i+2];
for m := 0 to j-1 do
begin
SetLength(g,Length(g)+1);
g[Length(g)-1,0]:=l;
g[Length(g)-1,1]:=k;
end;
Inc(i);
end;
c:=0;e:=0;b:=0;
SetLength(n,Length(g));
SetLength(o,Length(g));
for p := 0 to Length(g)-1 do
begin
q:=g[p][0];
r:=g[p][1]-q;
c:=Max(c,q);
e:=Max(e,r);
SetLength(n[p],q);
for I := 0 to q-1 do
n[p][i]:= 255 and data.buff[i+b];
b:=b+q;
s:=getErrorCorrectPolynomial(r);
t:=getNumArr(n[p],Length(s)-1);
u:=ArrMod(t,s);
SetLength(o[p],Length(s)-1);
for I := 0 to Length(o[p])-1 do
begin
v:=i+length(u)- Length(o[p]);
if v>=0 then
o[p][i]:=u[v]
else o[p][i]:=0;
end;
end;
SetLength(Result,totalDataCount);
x:=0;
for I := 0 to c-1 do
begin
for p := 0 to Length(g)-1 do
begin
if i<Length(n[p]) then
begin
Result[x]:=n[p][i];
Inc(x);
end;
end;
end;
for I := 0 to e-1 do
begin
for p := 0 to Length(g)-1 do
begin
if i<Length(o[p]) then
begin
if x>=Length(Result) then SetLength(Result,x+1);
Result[x]:=o[p][i];
inc(x);
end;
end;
end;
end;
function TQRCode.getNumArr(SArr: array of Integer; b: Integer):TIntArr;
var
I,j: Integer;
begin
i:=0;
if length(sArr)=0 then raise Exception.Create('getNumArr Err:'+ length(Sarr).toString + '/' + b.toString);
for I := 0 to Length(SArr)-1 do
begin
if SArr[i]<>0 then Break;
end;
SetLength(result,0);
SetLength(result,Length(SArr)-i+b);
for j := 0 to Length(SArr)-i-1 do
Result[j]:=SArr[j+i];
for i := j to Length(Result)-1 do
if Result[i]<0 then
Result[i]:=0;
end;
procedure TQRCode.getUtf8Bytes(CodeStr:string);
var
I,J,n: Integer;
temArr:TIntArr;
begin
SetLength(QrCodeBytes,0);
for I := 1 to Length(CodeStr) do
begin
temArr:= getCharByte(ord(CodeStr[i]));
SetLength(QrCodeBytes,Length(QrCodeBytes)+length(temArr));
for j := 0 to Length(temArr)-1 do
begin
n:= Length(QrCodeBytes)-length(temArr)+j;
QrCodeBytes[n]:=temArr[j];
end;
end;
end;
//return 128 > a ? [a] : 2048 > a ? (b = 192 + (a >> 6), c = 128 + (63 & a), [b, c]) : (b = 224 + (a >> 12), c = 128 + (63 & a >> 6), d = 128 + (63 & a), [b, c, d])
function TQRCode.getCharByte(ACII: Integer):TIntArr;
begin
if ACII<128 then
begin
SetLength(Result,1);
Result[0]:=ACII;
end else if ACII<2048 then
begin
SetLength(Result,2);
Result[0]:=192 + (ACII shr 6);
Result[1]:=128+(63 and ACII);
end else
begin
// Result[0]:=224+(ACII shr 12);
// Result[1]:= 128+ (63 and ACII shr 6);
// Result[2]:= 128 + (63 and ACII);
SetLength(Result,3);
Result[0]:=224+(ACII shr 12);
Result[1]:= 128+ (63 and (ACII shr 6));
Result[2]:= 128 + (63 and ACII);
end;
end;
procedure TQRCode.TPixelFour.setBlank;
begin
red := $FF;
blue := $FF;
green := $FF;
Alpha := $FF;
end;
procedure TQRCode.TPixelFour.setBlack;
begin
red:=0;
blue:=0;
green:=0;
Alpha:=0;
end;
end.
扫一扫
622
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
