barcode.pas

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

    //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+120)
      else
      aC.MoveTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY+120);
      aC.LineTo(Brx + (Inx - 1) * BrStep + Iny - 1, BrY +262)
    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+262,InPtS) ;
//设置条码字体
  With aC.Font do
  begin
  Charset := GB2312_CHARSET;
  //  Name := 'Arial Narrow';
    //Style := [fsItalic];
    Name := 'Wingdings';
    //Style := [fsItalic];
    //PixelsPerInch:=192;
    PixelsPerInch:=24;
    Size := BrStep*36+2 ;
  end;
  //输出条码字体

  //for Inx:=1 to Length(InPtS) do
       Inx:=1;
      aC.TextOut(7,BrY,'居民身份证') ;
      //aC.TextOut(20*(Inx-1),BrY,InPtS) ;
  //***********************************
end;
//***************************
function ClearCanvas(var CodeCanvas:Timage):boolean;
var
ClientRect:TRect;
begin
  ClientRect.Left:=0;
  ClientRect.Top:=0;
  ClientRect.Right:=CodeCanvas.Width;
  ClientRect.Bottom:=CodeCanvas.Height;
  with CodeCanvas.Canvas do
  begin
    Brush.Style:=bssolid;
    Brush.Color:=ClWhite;
    FillRect(ClientRect);
  end;
  result:=true;
end;

//*****************************
//****************
 function MakBMPHead(Mem:TStream): Boolean;
var//采用流来生成
  XInx: LONGINT;
  Mem1,Mem2:TMemoryStream;
  BMPHead1:tagBITMAPFILEHEADER;
  BMPHead2: TBitmapInfoHeader;
  BitsTotal:DWord;
begin
  Result:=False;
  Mem.Position:=0;
  Mem.Read(BMPHead1,SizeOf(tagBITMAPFILEHEADER));//读取BMP文件由文件头
  Mem.Read(BMPHead2,SizeOf(TBitmapInfoHeader));// 读取BMP位图信息头
  XInx:=BMPHead2.biXPelsPerMeter;
  XInx:=BMPHead2.biYPelsPerMeter;
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.