unit BarCode;
//39条码 EAN13条码 函数集
interface
uses Windows, SysUtils, Graphics;
const
BcCode39: array[0..42] of string =
('101001101101', '110100101011', '101100101011', '110110010101', '101001101011',
'110100110101', '101100110101', '101001011011', '110100101101', '101100101101',
'110101001011', '101101001011', '110110100101', '101011001011', '110101100101',
'101101100101', '101010011011', '110101001101', '101101001101', '101011001101',
'110101010011', '101101010011', '110110101001', '101011010011', '110101101001',
'101101101001', '101010110011', '110101011001', '101101011001', '101011011001',
'110010101011', '100110101011', '110011010101', '100101101011', '110010110101',
'100110110101', '100101011011', '110010101101', '100100100101', '100100101001',
'100101001001', '101001001001', '100101101101');
BcChar39: array[0..42] of char =
('0', '1', '2', '3', '4',
'5', '6', '7', '8', '9',
'A', 'B', 'C', 'D', 'E',
'F', 'G', 'H', 'I', 'J',
'K', 'L', 'M', 'N', 'O',
'P', 'Q', 'R', 'S', 'T',
'U', 'V', 'W', 'X', 'Y',
'Z', '-', '.', '$', '/',
'+', '%', '*');
BcCodeEan: array[0..29] of string =
('1110010', '1100110', '1101100', '1000010', '1011100',
'1001110', '1010000', '1000100', '1001000', '1110100',
'0001101', '0011001', '0010011', '0111101', '0100011',
'0110001', '0101111', '0111011', '0110111', '0001011',
'0100111', '0110011', '0011011', '0100001', '0011101',
'0111001', '0000101', '0010001', '0001001', '0010111');
BcECEan: array[1..9] of string =
('111111000000', '112122000000', '112212000000', '121122000000', '122112000000',
'122211000000', '121212000000', '121221000000', '122121000000');
//EAN13效验位计算
function GetEanVerify(InputS: string): string;
//EAN13条码输出
//aC 画板 R 区域 BrStep 步长 BrColor1 前景颜色 BrColor2 背景颜色
function PutImgBrEan(InPtS: string;
aC: TCanvas;
R: TRect;
BrStep: Word;
BrColor1: TColor = clBlack;
BrColor2: TColor = clWhite): string;
//39 条码识别 ScanC 0 - 输出黑白10序列 1 - 按步长解析成10序列 2 -解析成字符串
function ScanImgBr39(aC: TCanvas;
R: TRect;
ScanC: byte = 2): string;
//39 条码输出
procedure PutImgBr39(InPtS: string;
aC: TCanvas;
R: TRect;
BrStep: Word ;
BrColor1:TColor=clBlack;BrColor2:TColor=clWhite);
implementation
{*****************}
{ EAN 条码 }
{*****************}
function PutImgBrEan(InPtS: string;
aC: TCanvas;
R: TRect;
BrStep: Word;
BrColor1: TColor = clBlack;
BrColor2: TColor = clWhite): string;
var
bmXlStr: string;
Inx, Iny: Word;
OutPtStr: string;
BrX, BrY, BrHigh: Word;
//字符转打印序列
function BrCharToStr(I: Byte): string;
begin
result := '';
if I >= 2 then
case StrToInt(BmXlStr[I - 1]) of
0: result := BcCodeEan[0 + StrToInt(InPtS)];
1: result := BcCodeEan[10 + StrToInt(InPtS)];
2: result := BcCodeEan[20 + StrToInt(InPtS)];
end;
case I of
1: result := '101';
7: result := result + '01010';
13: result := result + '101';
end;
end;
begin
BmXlStr := BcECEan[StrToInt(InPtS[1])];
if Length(InPts)>=12 then
InPts:=Copy(InPts,1,12);
InPtS := GetEanVerify(InPtS);
OutPtStr := '';
result := '';
for Inx := 1 to Length(InPtS)do
begin
OutPtStr := OutPtStr + BrCharToStr(Inx);
result :=result + IntToStr(Inx)+':'+BrCharToStr(Inx)+'>' ;
end;
aC.Pen.Color := BrColor2;
aC.Rectangle(R);
BrX := R.Left;
BrY := R.Top;
BrHigh := R.Bottom - R.Top + 1;
//设置条码字体
With aC.Fontdo
begin
Name := 'OCR-B 10 BT';
Style := [fsBold];
Size := BrStep*6 ;
end;
//输出条码字体
aC.TextOut(BrStep*3,BrY + BrHigh-BrStep * 9,InPtS[1]);
for Inx:=2 to Length(InPtS)do
if Inx<=7 then
aC.TextOut(Round(BrStep*14) +BrStep*7*(Inx-2),BrY + BrHigh-BrStep * 9,InPtS[Inx])
else
aC.TextOut(Round(BrStep*14)+5*BrStep+BrStep*7*(Inx-2),BrY + BrHigh-BrStep * 9,InPtS[Inx]) ;
//输出打印序列
for Inx := 1 to Length(OutPtStr)do
for Iny := 1 to BrStepdo
begin
if OutPtStr[Inx] = '1' then
aC.Pen.Color := BrColor1
else
aC.Pen.Color := BrColor2;
aC.MoveTo(Brx + BrStep*10 + (Inx - 1) * BrStep + Iny - 1, BrY+BrStep * 5);
if Inx In [1..3,46..50,93..95] then
aC.LineTo(Brx + BrStep*10 + (Inx - 1) * BrStep + Iny - 1, BrY + BrHigh-BrStep * 5 )
else
aC.LineTo(Brx + BrStep*10 + (Inx - 1) * BrStep + Iny - 1, BrY + BrHigh-BrStep * 9);
end;
end;
//由7位或12位码产生相应校验位，从而生成标准8位或13位码
function GetEanVerify(InputS: string): string;
var
inx, sum: Integer;
begin
sum := 0;
for inx := 1 to length(InputS)do
begin
if (inx mod 2) = 1 then
sum := sum + (StrToInt(InputS[inx]) * 1)
else
sum := sum + (StrToInt(InputS[inx]) * 3);
end;
result := InputS + IntToStr(10 - (sum mod 10));
end;
{*****************}
{ 39 条码 }
{*****************}
procedure PutImgBr39(InPtS: string;
aC: TCanvas;
R: TRect;
BrStep: Word ;
BrColor1:TColor=clBlack;BrColor2:TColor=clWhite);
var
Inx, Iny: Word;
OutPtStr: string;
BrX, BrY, BrHigh: Word;
function BrCharToStr(S: string): string;
var
XInx: Integer;
begin
result := '';
for XInx := 0 to 42do
if S = BcChar39[XInx] then
begin
result := BcCode39[XInx];
Break;
end;
end;
function BrStrToStr(S: string): string;
var
XInx: Integer;
begin
result := '';
for XInx := 1 to Length(S)do
result := result + BrCharToStr(S[XInx]) + '0';
end;
begin
aC.Pen.Color:= BrColor2;
aC.Rectangle(R);
//BrColor2
OutPtStr := BrStrToStr(UpperCase(InPtS));
BrX := R.Left;
BrY := R.Top;
BrHigh := R.Bottom - R.Top + 1;
for Inx := 1 to Length(OutPtStr)do
for Iny := 1 to BrStepdo
begin
if OutPtStr[Inx] = '1' then
aC.Pen.Color := BrColor1
else
aC.Pen.Color := BrColor2;
aC.MoveTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY);
aC.LineTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY + BrHigh)
end;
end;
function ScanImgBr39(aC: TCanvas;
R: TRect;
ScanC: byte = 2): string;
var
ScanInx: byte;
StepLen,ScanStepHigh: Word;
ScanResult: array[0..2] of string;
function GetLuma(Color: TColor): Byte;
var
r, g, b: Byte;
begin
r := Color and $FF;
g := Color shr 8 and $FF;
b := Color shr 16 and $FF;
Result := Round(r * 0.3 + g * 0.59 + b * 0.11)
end;
function ScanStrToChar(S: string): string;
var
XInx: Integer;
begin
result := '';
for XInx := 0 to 42do
if S = BcCode39[XInx] then
begin
result := BcChar39[XInx];
Break;
end;
end;
function EncodeBr(s: string): string;
var
XInx, YInx, Charlen: word;
TestStepStr: string;
OldChar: Char;
UnitChar, EncodeChar: string;
begin
result := '';
if Length(S) < 5 then
Exit;
StepLen := StepLen;
for XInx := Round(StepLen / 5)do
wnto 1do
begin
TestStepStr := '';
for Yinx := 1 to XInxdo
TestStepStr := TestStepStr + '1';
if Pos('0' + TestStepStr + '0', S) > 0 then
StepLen := XInx;
end;
OldChar := '1';
Charlen := 0;
UnitChar := '';
EncodeChar := '';
if S[Length(S)] = '1' then
S := S + '0'
else
S := S + '1';
for XInx := 1 to Length(S)do
begin
if S[XInx] <> OldChar then
begin
OldChar := S[XInx];
Charlen := Length(UnitChar);
if OldChar = '1' then
case (CharLen * 10 div StepLen) of
5..14: EncodeChar := EncodeChar + '0';
15..35: EncodeChar := EncodeChar + '00'
end;
if OldChar = '0' then
case (CharLen * 10 div StepLen) of
5..19: EncodeChar := EncodeChar + '1';
20..35: EncodeChar := EncodeChar + '11'
end;
UnitChar := OldChar;
end
else
UnitChar := UnitChar + OldChar;
end;
YInx := 0;
UnitChar := '';
EncodeChar := EncodeChar + '1';
//result := S+' >> '+EncodeChar ;
case ScanC of
1: begin
result := EncodeChar ;
end;
2:
begin
for XInx := 1 to Length(EncodeChar)do
begin
Inc(YInx);
if YInx <= 12 then
UnitChar := UnitChar + EncodeChar[XInx]
else
if EncodeChar[XInx] = '1' then
begin
YInx := 1;
result := result + ScanStrToChar(UnitChar);
UnitChar := '1';
end;
end;
end;
end;
end;
function ScanImgBrXul(Y: word): string;
var
ColorAvg, ColorMax, ColorMin: Integer;
XInx: Integer;
Bcbegin
: Boolean;
S: string;
begin
Bcbegin
:= False;
result := '';
ColorAvg := 0;
ColorMax := 0;
ColorMin := 255;
for XInx := R.Left to R.Rightdo
begin
ColorAvg := GetLuma(aC.Pixels[XInx, Y]);
if ColorAvg < ColorMin then
ColorMin := ColorAvg;
if ColorAvg > ColorMax then
ColorMax := ColorAvg;
end;
ColorAvg := Round(ColorMin + 0.6 * (ColorMax - ColorMin));
if ColorAvg >= 255 then
ColorAvg := 200;
for XInx := R.Left to R.Rightdo
begin
if not (Bcbegin
) and (GetLuma(aC.Pixels[XInx, Y]) < ColorAvg) then
Bcbegin
:= True;
if Bcbegin
then
result := result + IntToStr(1 - (GetLuma(aC.Pixels[XInx, Y]) div ColorAvg));
//if (GetLuma(aC.Pixels[XInx, Y]) < ColorAvg) then
// aC.Pixels[XInx, Y] := ClRed
//else
// aC.Pixels[XInx, Y] := clYellow;
end;
for XInx := Length(result)do
wnto 1do
if result[XInx] = '0' then
result := Copy(result, 1, XInx - 1)
else
Break;
end;
begin
result := '';
ScanInx := 0;
ScanStepHigh:= ( R.Bottom - R.Top + 1 ) div 3 ;
case ScanC of
0: begin
for ScanInx := 0 to 2do
ScanResult[ScanInx] := ScanImgBrXul(((R.Top + R.Bottom) div 2) + (-ScanStepHigh + ScanStepHigh * (ScanInx mod 3)));
result := '1: '+ScanResult[0] + ' 2: ' + ScanResult[1] + ' 3: ' + ScanResult[2]+' END';
end;
1..2:
begin
for ScanInx := 0 to 2do
ScanResult[ScanInx] := ScanImgBrXul(((R.Top + R.Bottom) div 2) + (-ScanStepHigh + ScanStepHigh * (ScanInx mod 3)));
if ScanResult[0] = ScanResult[1] then
result := EncodeBr(ScanResult[0])
else
if ScanResult[1] = ScanResult[2] then
result := EncodeBr(ScanResult[1])
else
if ScanResult[2] = ScanResult[0] then
result := EncodeBr(ScanResult[2]);
end;
end;
end;
end.
