printbarcode.pas

条形码编码算法

            BarWidths[4] := 3; BarWidths[5] := 1; BarWidths[6] := 1; END;
  99: BEGIN BarWidths[1] := 1; BarWidths[2] := 1; BarWidths[3] := 3;
            BarWidths[4] := 1; BarWidths[5] := 4; BarWidths[6] := 1; END;
 100: BEGIN BarWidths[1] := 1; BarWidths[2] := 1; BarWidths[3] := 4;
            BarWidths[4] := 1; BarWidths[5] := 3; BarWidths[6] := 1; END;
 101: BEGIN BarWidths[1] := 3; BarWidths[2] := 1; BarWidths[3] := 1;
            BarWidths[4] := 1; BarWidths[5] := 4; BarWidths[6] := 1; END;
 102: BEGIN BarWidths[1] := 4; BarWidths[2] := 1; BarWidths[3] := 1;
            BarWidths[4] := 1; BarWidths[5] := 3; BarWidths[6] := 1; END;
 103: BEGIN BarWidths[1] := 2; BarWidths[2] := 1; BarWidths[3] := 1;
            BarWidths[4] := 4; BarWidths[5] := 1; BarWidths[6] := 2; END;
 104: BEGIN BarWidths[1] := 2; BarWidths[2] := 1; BarWidths[3] := 1;
            BarWidths[4] := 2; BarWidths[5] := 1; BarWidths[6] := 4; END;
 105: BEGIN BarWidths[1] := 2; BarWidths[2] := 1; BarWidths[3] := 1;
            BarWidths[4] := 2; BarWidths[5] := 3; BarWidths[6] := 2; END;
{106: BEGIN BarWidths[1] := 2; BarWidths[2] := 1; BarWidths[3] := 2;}
{           BarWidths[4] := 2; BarWidths[5] := 2; BarWidths[6] := 2; END;}
  END; {CASE}
END;

BEGIN
  Sender.Brush.color := Self.Color;
  EnCode(ch); {returned in BarsWidths}
  drk := true;
  for i := 1 to 6  do
  BEGIN
  printbar(Sender,drk,BarWidths[i]);
  drk := not Drk;
  END;
END;


PROCEDURE AddCC(ch : char);
BEGIN
   CodeChars[CCPtr] := ch;
   CCPtr := CCPtr + 1;
END;

PROCEDURE AddNCode(ch : char);
BEGIN
  if ord(ch) < 32 then AddCC(chr(ord(ch) + 64))
  else
  AddCC(chr(ord(ch) - 32))
END;




PROCEDURE TranslateCode;
TYPE CodeTypeS = (A,B,C,None);
VAR SPtr, SLen, NextC, NextS2 : integer;
    CodeType: CodeTypes;

FUNCTION  TrySetC(TempPtr : integer) : Boolean;
var i : integer;
BEGIN
   result := false;
   if TempPtr > SLen - 3 then exit;
{test for 4 consec digits}
    for i := TempPtr to  (TempPtr + 3) DO
    if not (s[i] in ['0'..'9']) then exit;
    result := true;
 END;

 PROCEDURE DoSetC;
 var ch : char;
 BEGIN
    if CodeType <> C then AddCC(#99);
    Codetype := C;
    while (SPtr <= SLen - 1)
            and (s[SPtr] in ['0'..'9'])
            and (s[SPtr + 1] in ['0'..'9']) do
    BEGIN
       ch :=   chr(10 * (ord(s[SPtr]) - 48)  + ord(s[SPtr + 1]) - 48);
       AddCC(ch);
       SPtr := SPtr + 2;
    END;

 END;

 FUNCTION TryNextCode(startPtr : integer) : CodeTypeS;
 var Found : boolean;
    i : integer;
 BEGIN
   result  := B;
   if StartPtr > SLen then exit;
   i := StartPtr - 1;
   found := false;
   REPEAT
     i := i + 1;
     if ord(s[i]) <= 31 then
     BEGIN
       Result := A;
       Found := true;
     END;
     if ord(s[i]) >= 96 then
     BEGIN
     Result := B;
     Found := true;
     END;
   UNTIL (i = SLen) or found;

 END;


 PROCEDURE FindNextC ;
 var i : integer;
 BEGIN
   {ie not before END of string}
   i := SPtr -1;
   REPEAT
     i := i + 1;
   UNTIL (i >= SLen) or TrySetC(i);
   NextC := i;
   if NextC = SLen then NextC := SLen + 1{(i = SLen + 1) means  not before END of string}
 END;


 PROCEDURE DoSetA;
Var NextB : integer;
    MustStop : boolean;

 PROCEDURE TryNextB(startPtr : integer;var ItsPtr : integer);
 BEGIN
      ItsPtr := StartPtr - 1;
   REPEAT
     ItsPtr := ItsPtr + 1;
   UNTIL (ItsPtr > SLen) or (ord(s[ItsPtr]) >= 96);
 END;



 BEGIN
    if CodeType <> A then AddCC(#101);
    Codetype := A;
    MustStop := false;
    TryNextB(SPtr,NextB);
    REPEAT
    while (SPtr <= NextB - 1) and (SPtr <= NextC - 1) and (SPtr <= SLen) do
    BEGIN
       AddNCode(s[SPtr]);
       SPtr := SPtr + 1;
    END;
    if SPtr >= NextC then MustStop := true {nextC <= SLen}
    else
    if SPtr > SLen then MustStop := true {nextC <= SLen}
    else
    BEGIN {CAN ASSUME SPtr = NEXT A}
       if TryNextCode(SPtr + 1) = B then MustStop := true
      else
      AddCC(chr(98));{ONE CODE B ONLY.. USE SHIFT}
    END;
    UNTIL MustStop;
 END;



 PROCEDURE DoSetB;
Var NextA : integer;
        MustStop : boolean;

 PROCEDURE TryNextA(startPtr : integer;var ItsPtr : integer);
 BEGIN
      ItsPtr := StartPtr - 1;
   REPEAT
     ItsPtr := ItsPtr + 1;
   UNTIL (ItsPtr > SLen) or (ord(s[ItsPtr]) >= 96);
 END;


 BEGIN
    if CodeType <> B then AddCC(#100);
    Codetype := B;
    MustStop := false;
    TryNextA(SPtr,NextA);
    REPEAT
    while (SPtr <= NextA - 1) and (SPtr <= NextC - 1) and (SPtr <= SLen) do
    BEGIN
       AddNCode(s[SPtr]);
       SPtr := SPtr + 1;
    END;
    if SPtr >= NextC then MustStop := true {nextC <= SLen ie if END of string , this is true}
    else
    if SPtr > SLen then MustStop := true
    else
    BEGIN {CAN ASSUME SPtr = NEXT A}
       if TryNextCode(SPtr + 1) = A then MustStop := true
      else
      BEGIN
       TryNextA(SPtr + 1,NextA);{Move Next A on further}
       AddCC(chr(98));{ONE CODE A ONLY.. USE SHIFT}
      END;
    END;
    UNTIL MustStop;
 END;



 BEGIN {TranslateCode}
  SPtr := 1; CCPtr := 1;
  SLen := length(s);
  FindNextC;
  if NextC = 1 then BEGIN CodeType := C; AddCC(chr(105)); END {startC}
  else
  if TryNextCode(1) = A then BEGIN Codetype := A; AddCC(chr(103)); END
  else BEGIN CodeType := B; AddCC(chr(104)); END;
  if EAN128 then AddCC(#102);
  REPEAT
    if  TrySetC(SPtr)  then DoSetC;
    FindNextC;
    if (SPtr <= (NextC - 1)) then
    BEGIN
      if TryNextCode(SPtr) = A then DoSetA  else DoSetB;
    END;
  UNTIL SPtr > SLen;
END;




PROCEDURE AddCheckSum;
var i, ExtraChar : integer;
    ChkSum : longint;{can have long barcodes}
BEGIN
{Test of checksum... will assume Code128 uses identical to Ean128}
{ Replace EAN128 with true}
  ChkSum := 0;

  if true then{was if EAN128}
  BEGIN
  ExtraChar := 1;
  ChkSum := ord(CodeChars[1]);
  END
  else ExtraChar  := 0;
  for i := (1 )  to   (CCPtr -1 - ExtraChar) do
    ChkSum := ChkSum + ord(CodeChars[i + ExtraChar]) * i;
  ChkSum := ChkSum mod 103;
  AddCC(chr(ChkSum));
END;

BEGIN{PCode128}
    Wide := round(UsePixelsPerInchX * 0.03937 * FMagnification);{1mm  = 0.03937" = X 1 magnification ie standard}
    if Wide = 0 then Wide := 1;
    ThisHeight := 32 * Wide; {technically 31.8 * wide}
    if EAN128 then
    if ThisHeight < UsePixelsPerInchX * 0.7874 then   {0.7874" = 20mm =  min allowed height}
           ThisHeight := round(UsePixelsPerInchX * 0.7874);
    TranslateCode;
    AddCheckSum;
    IF FClearZone then Leadin := 10 else Leadin := 0;
    {no stop yet}
    if Sender = Self.Canvas then
    BEGIN
     Self.WIdth :=  Wide * 11 * (CCPtr) + 13 * wide + 2 * Leadin * Wide;
     Self.Height := ThisHeight;
    END;
     {    Sender.Font.Name := 'Ariel';}{no I don't think so .. use default }
   Sender.Font.Assign(Self.font);
   Sender.Font.Height := Wide * 4;{must be after wide is allocated}
   Sender.Font.Style := [fsBold];
    Sender.Pen.color := Self.color;
    Sender.Rectangle(StartX,StartY,
            Wide * 11 * (CCPtr ) + 13 * wide + 2 * Leadin * Wide + StartX,
            ThisHeight + StartY {+ (11 * wide)});
    Sender.Brush.color := Self.Color;
{    StartX := StartX + 7*Wide;}
{    StartY := StartY + Wide;}
    StartPoint := 0;

    {space at start}
    PrintBar(Sender,false,Leadin);
    SI := 1;
    REPEAT
      BarChar(CodeChars[SI]);
      SI := SI + 1;
    UNTIL (SI >= CCPtr);
        {Stop Symbol}
    PrintBar(Sender,true,2);
    PrintBar(Sender,False,3);
    PrintBar(Sender,true,3);
    PrintBar(Sender,False,1);
    PrintBar(Sender,true,1);
    PrintBar(Sender,False,1);
    PrintBar(Sender,true,2);

    {space at END .. done in rect}
    PrintBar(Sender,false,Leadin);

  END;



BEGIN{DrawBarCode}
    if UsePixelsPerInchX < 5 then
    UsePixelsPerInchX := Screen.PixelsPerInch;

  IF PrintWhere is TForm then
  BEGIN
    if UsePixelsPerInchX = 0 then UsePixelsPerInchX := TForm(PrintWhere).PixelsPerInch;
    WhichCanvas := TForm(PrintWhere).Canvas;
  END
  else
  IF PrintWhere is TCanvas then
  BEGIN
    if PrintWhere = Printer.Canvas then UsePixelsPerInchX := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSX);
{   Printer.canvas.font.PixelsPerInch}
    WhichCanvas := TCanvas(PrintWhere);
  END
  else
  IF PrintWhere is TPaintBox then
  BEGIN
    WhichCanvas := TPaintBox(PrintWhere).Canvas;
  END
  else
  BEGIN
    WhichCanvas := Self.Canvas;
  END;
  UsePixelsPerInchY := UsePixelsPerInchX;
  if PrintWhere = Printer.Canvas then UsePixelsPerInchY := GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);

  {POSITIONING}
  if whichCanvas = Self.canvas then
  BEGIN
    StartX := 0;
    StartY := 0;
  END
  ELSE
  BEGIN
  StartY := Self.top;
  StartX := Self.Left;
  if FAutoPosition then
  BEGIN
  Calc := Self.Top;
  StartY := Trunc(Calc  * UsePixelsPerInchY / Screen.PixelsPerInch) ;
  Calc := self.Left;
  StartX := Trunc(Calc  *  UsePixelsPerInchX / Screen.PixelsPerInch);
  END;
  END;
{auto sizing}
  UseHeight := Self.Height;
  UseWidth := Self.Width;
  if FAutoSizing then
  BEGIN
  IF Self.FBarcodeType IN [Code39,Interleaved2of5,ITF14] THEN
  BEGIN
   Calc := Self.Height;
  UseHeight := Trunc(Calc * UsePixelsPerInchY / Screen.PixelsPerInch) ;
  calc := Self.Width;
  UseWidth := Trunc(calc * UsePixelsPerInchX / Screen.PixelsPerInch);
  END;
  END;
  SavePenColor := WHichCanvas.pen.color;
  SaveBrushColor := WHichCanvas.Brush.color;
  SaveFont.Assign(WHichCanvas.Font);

  case Self.FBarcodeType of
  Code39: PCode39(Self.Text,WhichCanvas);
  Interleaved2of5 : PI2of5(self.text,WhichCanvas);
  ITF14 :  PITF14(self.text,WhichCanvas);
  PostNetZip      : PPostNEt(Self.text,WhichCanvas,5);
  PostNetZipPlus4    : PPostNEt(Self.text,WhichCanvas,9);
  PostNet11       : PPostNEt(Self.text,WhichCanvas,11);
  Code128 : PCode128(Self.text,WhichCanvas,false);
  EAN128 : PCode128(Self.text,WhichCanvas,TRUE);
  EAN, EAN8, EAN13   : PEAN(Self.text,WhichCanvas);
  PostNet      : if length(Self.text) < 6 then PPostNEt(Self.text,WhichCanvas,5)
                 else
                 if length(Self.text) < 6 then PPostNEt(Self.text,WhichCanvas,9)
                 else PPostNEt(Self.text,WhichCanvas,11);
  FIMA : PFIM('A',WhichCanvas);
  FIMB : PFIM('B',WhichCanvas);
  FIMC : PFIM('C',WhichCanvas);
  END;
  WHichCanvas.Font.Assign(SaveFont);
  WHichCanvas.pen.color := SavePenColor ;
  WHichCanvas.Brush.color := SaveBrushColor;
END;
end.