barcode.pas

身份证ean128条码生成器,包括15身份证自动升级到18位

unit BarCode; //39条码 EAN13条码 函数集

interface

uses Windows, SysUtils, Graphics,Classes,
  Messages, Variants, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;
const
  BcCode39l: array[0..102] of string =
  (
    '11011001100', '11001101100', '11001100110', '10010011000','10010001100', '10001001100',
    '10011001000', '10011000100', '10001100100', '11001001000', '11001000100',
    '11000100100', '10110011100', '10011011100', '10011001110', '10111001100',
  //0 to 9  (16~25)
  '10011101100', '10011100110', '11001110010', '11001011100', '11001001110',
    '11011100100', '11001110100', '11101101110', '11101001100', '11100101100',
    //(26~32)
    '11100100110', '11101100100', '11100110100', '11100110010' ,'11011011000',
    '11011000110', '11000110110',
 //A to Z (33~58)
    '10100011000', '10001011000', '10001000110', '10110001000', '10001101000',
    '10001100010', '11010001000', '11000101000', '11000100010', '10110111000',
    '10110001110', '10001101110', '10111011000', '10111000110', '10001110110',
    '11101110110', '11010001110', '11000101110', '11011101000', '11011100010',
    '11011101110', '11101011000', '11101000110', '111OOO1O11O', '11101101000',
    '11101100010',
    //(59~64)
    '11100011010', '11101111010', '11001000010', '11110001010', '10100110000',
    '10100001100', '10010110000', //a(65)
    //b~z(66~90)
    '10010000110', '10000101100', '10000100110', '10110010000', '10110000100',
    '10011010000', '10011000010', '10000110100', '10000110010', '11000010010',
    '11001010000', '11110111010', '11000010100', '10001111010', '10100111100',
    '10010111100', '10010011110', '10111100100', '10011110100', '10011110010',
    '11110100100', '11110010100', '11110010010', '11011011110', '11011110110',
    //(91~102)
    '11110110110', '10101111000', '10100011110', '10001011110', '10111101000',

    '10111100010', '11110101000', '11110100010', '10111011110', '10111101110',
    '11101011110', '11110101110');
 BcInt39l: array[0..102] of integer =
  (
    0,1,2,3,4,5,6,7,8,9,10,
    11,12,13,14,15,16, 17, 18, 19, 20,
    21, 22, 23, 24, 25,26,27,28,29,30,
    31,32, 33, 34, 35,36, 37,38, 39, 40,
    41,42, 43,44,45,46,47,
    48,49,50,51,52,
    53,54,55,56,57,
    58,59,60,61,62,63,64,65,
    66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,
    81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102);

  BcCode39: array[0..42] of string =
  (

   //0 to 9  (16~25)
  '10011101100', '10011100110', '11001110010', '11001011100', '11001001110',
    '11011100100', '11001110100', '11101101110', '11101001100', '11100101100',
 //A to Z (33~58)
    '10100011000', '10001011000', '10001000110', '10110001000', '10001101000',
    '10001100010', '11010001000', '11000101000', '11000100010', '10110111000',
    '10110001110', '10001101110', '10111011000', '10111000110', '10001110110',
    '11101110110', '11010001110', '11000101110', '11011101000', '11011100010',
    '11011101110', '11101011000', '11101000110', '111OOO1O11O', '11101101000',
    '11101100010',
    //(59~64)
    '11100011010', '11101111010', '11001000010', '11110001010', '10100110000',
    '10100001100', '10010110000' );
  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', '-', '.', '$', '/',
    '+', '%', '*');
    BcInt39: array[0..42] of integer =
  (
    16, 17, 18, 19, 20,
    21, 22, 23, 24, 25,
     33, 34, 35,36, 37,38, 39, 40,
    41,42, 43,44,45,46,47,
    48,49,50,51,52,
    53,54,55,56,57,
    58,59,60,61,62,63,64,65);



//39 条码识别  ScanC 0 - 输出黑白10序列 1 - 按步长解析成10序列 2 -解析成字符串
function ScanImgBr39(aC: TCanvas; R: TRect; ScanC: byte = 2): string;
//39 条码输出
procedure PutImgBr39(InPtS: string;ends:string; aC: TCanvas; R: TRect; BrStep: Word ; BrColor1:TColor=clBlack;BrColor2:TColor=clWhite);
procedure PutImgBr128(InPtS: string;ends:string; aC: TCanvas; R: TRect; BrStep: Word ; BrColor1:TColor=clBlack;BrColor2:TColor=clWhite);

function ClearCanvas(var CodeCanvas:Timage):boolean;
function MakBMPHead(Mem:TStream): Boolean;
function aoo(t:byte):string;

function BrCharToInt(S: string): integer;
function BrIntToStr1(S:integer ): string;
implementation

function aoo(t:byte):string;
begin
case  t of
 0: result:='1';
 1: result:='0';
 2: result:='X';
 3: result:='9';
 4: result:='8';
 5: result:='7';
 6: result:='6';
 7: result:='5';
 8: result:='4';
 9: result:='3';
 10: result:='2';

 end;
end;
     

function BrCharToInt(S: string): integer;
  var
    XInx: Integer;
  begin
    result := 0;
    for XInx := 0 to 42 do
      if S = BcChar39[XInx] then
      begin
        result := BcInt39[XInx];
        Break;
      end;
  end;
function BrIntToStr1(S:integer ): string;
  var
    XInx: Integer;
  begin
    result := '';
    for XInx := 0 to 102 do
      if S = BcInt39l[XInx] then
      begin
        result := BcCode39l[XInx];
        Break;
      end;
  end;
{*****************}
{     a 条码     }
{*****************}

procedure PutImgBr39(InPtS: string;ends: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 := '1101000010011110101110';
    result := '11010010000';
    for XInx := 1 to Length(S) do
      result := result + BrCharToStr(S[XInx]);
    result := result + ends+ '1100011101011';
  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;
  //********************************
  aC.Pen.Color := BrColor2;
  aC.Rectangle(R);
  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;
      if Inx In [1..85] then
      //aC.MoveTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY+37)
      aC.MoveTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY+60)
      else
      aC.MoveTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY+60);
      aC.LineTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY +168)
    end;
 //设置条码字体
  With aC.Font do
  begin
  Charset := GREEK_CHARSET;
  //  Name := 'Arial Narrow';
    //Style := [fsItalic];
    Name := 'Wingdings';
    //Style := [fsItalic];
    //PixelsPerInch:=192;
    Pitch :=fpFixed;
    PixelsPerInch:=24;
    Size := BrStep*34+2;
  end;
  //输出条码字体

  //for Inx:=1 to Length(InPtS) do
       Inx:=1;
       aC.TextOut(161,BrY+168,InPtS) ;
//设置条码字体
  With aC.Font do
  begin
  Charset := GB2312_CHARSET;
  //  Name := 'Arial Narrow';
    //Style := [fsItalic];
    Name := 'Wingdings';
    //Style := [fsItalic];
    //PixelsPerInch:=192;
    PixelsPerInch:=24;
    Size := BrStep*46+2 ;
  end;
  //输出条码字体

  //for Inx:=1 to Length(InPtS) do
       Inx:=1;
      aC.TextOut(12,BrY,'居民身份证') ;
      //aC.TextOut(20*(Inx-1),BrY,InPtS) ;
  //***********************************
end;
//***************************
{*****************}
{     b 条码     }
{*****************}

procedure PutImgBr128(InPtS: string;ends: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