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[I])];
        1: result := BcCodeEan[10 + StrToInt(InPtS[I])];
        2: result := BcCodeEan[20 + StrToInt(InPtS[I])];
      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.Font do
  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 BrStep do
    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 42 do
      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 BrStep do
    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 42 do
      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) downto 1 do
    begin
      TestStepStr := '';
      for Yinx := 1 to XInx do
        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.Right do
    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.Right do
    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) downto 1 do
      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 2 do
          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 2 do
          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.