printbarcode.pas

条形码编码算法

unit PrintBarcode;

interface
PROCEDURE DrawBarCode(PrintWhere : TObject;UsePixelsPerInchX : integer);
implementation


PROCEDURE DrawBarCode(PrintWhere : TObject;UsePixelsPerInchX : integer);
var
  Slength, LeadIn : integer;
  Wide, Narrow, mult, Height : integer; {# pixels}
  {BarBox : TPaintBox;}
  StartPoint : integer; {where Barcode next bar Starts}
  StartX, StartY : integer;
  WhichCanvas : TCanvas;
  UsePixelsPerInchY : integer;
  Calc : double;

PROCEDURE  printbar(Sender : TCanvas; drk, WideBar : boolean); {Uses global vars so all procs can call}
var Barwidth : integer;
BEGIN

  with  Sender do
  BEGIN
  if drk then Pen.Color := FBarColor  else  Pen.Color := Self.color;
  if drk then  Brush.Color := FBarColor else Brush.Color := Self.color;
  if WideBar then Barwidth := Wide else BarWidth := Narrow;
  Rectangle(StartPOint + StartX,0+ StartY,StartPOint + BarWidth + StartX,UseHeight + StartY);
  StartPoint := StartPOint + BarWidth;

  {if WideBar then
    BEGIN
      OffSet := Wide div 2;
      Pen.Width := Wide;
      MoveTo(StartPoint + OffSet,0);
      LineTo(StartPoint + OffSet,Height);
      StartPoint := StartPOint + Wide;
    END
    else
    BEGIN
      OffSet := Narrow div 2;
      Pen.Width := Narrow;
      MoveTo(StartPoint + OffSet,0);
      LineTo(StartPoint + OffSet,Height);
    StartPoint := StartPOint + Narrow;
    END;
  }
  END
  {ELSE  (was not dark)
  BEGIN
    if WideBar then
    StartPoint := StartPOint + Wide
    else
    StartPoint := StartPOint + Narrow;
  END;
  }
END;




procedure PCode39(S : string; Sender: TCanvas);
var
SI, LI : integer;
ClearSize : integer;


PROCEDURE barchar(ch : char);
var Drk : boolean;
    i : integer;



     PROCEDURE EnCode(ch : char);
     BEGIN
       Bars := blank;
       case ch of
       '0' : BEGIN Bars[4] := true; Bars[5] := true; Bars[7] := true; END;
       '1' : BEGIN Bars[1] := true; Bars[4] := true; Bars[9] := true; END;
       '2' : BEGIN Bars[3] := true; Bars[4] := true; Bars[9] := true; END;
       '3' : BEGIN Bars[1] := true; Bars[3] := true; Bars[4] := true; END;
       '4' : BEGIN Bars[4] := true; Bars[5] := true; Bars[9] := true; END;
       '5' : BEGIN Bars[1] := true; Bars[4] := true; Bars[5] := true; END;
       '6' : BEGIN Bars[3] := true; Bars[4] := true; Bars[5] := true; END;
       '7' : BEGIN Bars[4] := true; Bars[7] := true; Bars[9] := true; END;
       '8' : BEGIN Bars[1] := true; Bars[4] := true; Bars[7] := true; END;
       '9' : BEGIN Bars[3] := true; Bars[4] := true; Bars[7] := true; END;
       'A' : BEGIN Bars[1] := true; Bars[6] := true; Bars[9] := true; END;
       'B' : BEGIN Bars[3] := true; Bars[6] := true; Bars[9] := true; END;
       'C' : BEGIN Bars[1] := true; Bars[3] := true; Bars[6] := true; END;
       'D' : BEGIN Bars[5] := true; Bars[6] := true; Bars[9] := true; END;
       'E' : BEGIN Bars[1] := true; Bars[5] := true; Bars[6] := true; END;
       'F' : BEGIN Bars[3] := true; Bars[5] := true; Bars[6] := true; END;
       'G' : BEGIN Bars[6] := true; Bars[7] := true; Bars[9] := true; END;
       'H' : BEGIN Bars[1] := true; Bars[6] := true; Bars[7] := true; END;
       'I' : BEGIN Bars[3] := true; Bars[6] := true; Bars[7] := true; END;
       'J' : BEGIN Bars[5] := true; Bars[6] := true; Bars[7] := true; END;
       'K' : BEGIN Bars[1] := true; Bars[9] := true; Bars[8] := true; END;
       'L' : BEGIN Bars[3] := true; Bars[9] := true; Bars[8] := true; END;
       'M' : BEGIN Bars[1] := true; Bars[3] := true; Bars[8] := true; END;
       'N' : BEGIN Bars[5] := true; Bars[9] := true; Bars[8] := true; END;
       'O' : BEGIN Bars[1] := true; Bars[5] := true; Bars[8] := true; END;
       'P' : BEGIN Bars[3] := true; Bars[5] := true; Bars[8] := true; END;
       'Q' : BEGIN Bars[7] := true; Bars[9] := true; Bars[8] := true; END;
       'R' : BEGIN Bars[1] := true; Bars[7] := true; Bars[8] := true; END;
       'S' : BEGIN Bars[3] := true; Bars[7] := true; Bars[8] := true; END;
       'T' : BEGIN Bars[5] := true; Bars[7] := true; Bars[8] := true; END;
       'U' : BEGIN Bars[1] := true; Bars[2] := true; Bars[9] := true; END;
       'V' : BEGIN Bars[2] := true; Bars[3] := true; Bars[9] := true; END;
       'W' : BEGIN Bars[1] := true; Bars[2] := true; Bars[3] := true; END;
       'X' : BEGIN Bars[2] := true; Bars[5] := true; Bars[9] := true; END;
       'Y' : BEGIN Bars[1] := true; Bars[2] := true; Bars[5] := true; END;
       'Z' : BEGIN Bars[2] := true; Bars[3] := true; Bars[5] := true; END;
       '-' : BEGIN Bars[2] := true; Bars[7] := true; Bars[9] := true; END;
       '.' : BEGIN Bars[1] := true; Bars[2] := true; Bars[7] := true; END;
       ' ' : BEGIN Bars[2] := true; Bars[3] := true; Bars[7] := true; END;
       '$' : BEGIN Bars[2] := true; Bars[4] := true; Bars[6] := true; END;
       '/' : BEGIN Bars[2] := true; Bars[4] := true; Bars[8] := true; END;
       '+' : BEGIN Bars[2] := true; Bars[6] := true; Bars[8] := true; END;
       '%' : BEGIN Bars[4] := true; Bars[6] := true; Bars[8] := true; END;
       '*' : BEGIN Bars[2] := true; Bars[5] := true; Bars[7] := true; END;
     END;

END;

BEGIN
  EnCode(ch); {returned in Bars}
  drk := true;
  for i := 1 to 9  do
  BEGIN
  printbar(Sender,drk,Bars[i]);
  drk := not drk;
  END;
  printbar(Sender,false,false);
END;



{cODE 39 ration wide : narrow  > 1.8  < 3.4 }

Function TryRatio(TryWide, TryNarrow : integer) : boolean;
{BASICALLY TESTS TO SEE IF IT WILL FIT}
var Leadin, CharSize : integer;
BEGIN
  if not FClearZone then LeadIn := 0
  else
  if TryWIde > 3 then Leadin := 20 else Leadin := 16;
  CharSize := ((3 * TryWide) + (7 * TryNarrow));
  if ((Leadin * TryNarrow) + (CharSize  * (2 + SLength)) > UseWidth) then
  TryRatio := false
  else
  BEGIN
    TryRatio := true; {2:1}
    Wide := tryWide;
    Narrow := TryNarrow;
  END;
END;


BEGIN{PCode39}
  if s = ''  then exit;
  SLength := length(S);
  if (18 + 13 * (2 + SLength)) > UseWidth then  {2:1}
  BEGIN
    if Sender = Self.canvas then
    with  self, canvas do
  BEGIN
  Pen.Color := FBarColor;
{  if drk then  Brush.Color := FBarColor else Brush.Color := Self.color;}
{  if WideBar then Barwidth := Wide else BarWidth := Narrow;}
  Rectangle(0,0,width,height);
  END;
   exit;
  END;
  if  TryRatio(24,9) then{BIG ANYWAY}
  BEGIN
     if FClearZone then ClearSize := 0 else ClearSize := 19;
     {145 = 3 X Wide (24)  + 7 * Narrow (9)}
     mult := (UseWidth) div ((SLength + 2) * 145 + (Clearsize * 9));
     Wide := mult * 8;
     Narrow := Mult * 3;
  END
  ELSE
  IF NOT TryRatio(20,8) then
  IF NOT TryRatio(16,6) then
  IF NOT TryRatio(13,5) then
  IF NOT TryRatio(10,4) then
  IF NOT TryRatio(8,3) then
  IF NOT TryRatio(6,2) then
  IF NOT TryRatio(5,2) then
  IF NOT TryRatio(3,1) then
  BEGIN
    Wide := 2; Narrow := 1;
  END;
    Leadin :=  UseWidth -  (((3 * Wide) + (7 * Narrow))  * (2 + SLength));
    Leadin := (Leadin + Narrow)  div (2 * Narrow);
{    TCanvas(Sender).BringToFront;}
    Height := UseHeight;
    StartPoint := 0;
    if Leadin > 0 then
    for LI := 1 to Leadin do PrintBar(Sender,false,False);
    BarChar('*');
    For si := 1 to Length(s) do BarChar(s[SI]);
    BarChar('*');
    if Leadin > 1 then
    for LI := 1 to (Leadin - 1) do PrintBar(Sender,false,False);
  END;

procedure PI2Of5(S : string; Sender: TCanvas);
var
SI, LI : integer;
ClearSizePlusStartEND : integer;



PROCEDURE barchar(ch1,ch2 : char);
var i : integer;
     Bars2 : CharBool;


     PROCEDURE EnCode(ch : char);
     BEGIN
       Bars := blank;
       case ch of
       '0' : BEGIN Bars[3] := true; Bars[4] := true; END;
       '1' : BEGIN Bars[1] := true; Bars[5] := true; END;
       '2' : BEGIN Bars[2] := true; Bars[5] := true; END;
       '3' : BEGIN Bars[1] := true; Bars[2] := true; END;
       '4' : BEGIN Bars[3] := true; Bars[5] := true; END;
       '5' : BEGIN Bars[1] := true; Bars[3] := true; END;
       '6' : BEGIN Bars[2] := true; Bars[3] := true; END;
       '7' : BEGIN Bars[4] := true; Bars[5] := true; END;
       '8' : BEGIN Bars[1] := true; Bars[4] := true; END;
       '9' : BEGIN Bars[2] := true; Bars[4] := true; END;
     END;

END;

BEGIN
  EnCode(ch2); {returned in Bars}
  Bars2 := Bars;
  EnCode(ch1); {returned in Bars}
  for i := 1 to 5  do
  BEGIN
  printbar(Sender,true,Bars[i]);
  printbar(Sender,false,Bars2[i]);
  END;
END;




Function TryRatio(TryWide, TryNarrow : integer) : boolean;
{BASICALLY TESTS TO SEE IF IT WILL FIT}
var Leadin, CharSize, StartENDSymbols : integer;
BEGIN
  if not FClearZone then Leadin := 0 else
  if TryWIde > 3 then Leadin := 21 else {20 MINUTELY UNDER MIN DIMENSIONS}
  if TryWIde > 2 then Leadin := 20 else Leadin := 12;{28 = blank + start & stop bars}
  CharSize := ((2 * TryWide) + (3 * TryNarrow));
  StartENDSymbols := 8 * TryNarrow;
  if ((Leadin * TryNarrow) + (CharSize  * (SLength) + StartENDSymbols)  > UseWidth) then
  TryRatio := false
  else
  BEGIN
    TryRatio := true; {2:1}
    Wide := tryWide;
    Narrow := TryNarrow;
  END;
END;


BEGIN{PI2of5}
  if s = ''  then exit;
  if ((length(s) mod 2) = 1) then s := '0' + s;
  SLength := length(S);
  if (16 + 7 * (SLength)) > UseWidth then
  BEGIN
     if Sender = Self.canvas then
     with  self,canvas do
  BEGIN
  Pen.Color := FBarColor;
{  if drk then  Brush.Color := FBarColor else Brush.Color := Self.color;}
{  if WideBar then Barwidth := Wide else BarWidth := Narrow;}
  Rectangle(0,0,width,height);
  END;
   exit; {2:1}
  END;
  if  TryRatio(24,9) then{BIG ANYWAY}
  BEGIN
     { start END = 8 narrow = 8   Clear = 21 narrow }
     if FClearZone then ClearSizePlusStartEND := 8  else ClearSizePlusStartEND := 8  + 21;
     {75 = 2 X Wide (24)  + 3 * Narrow (9)}
     mult := (UseWidth) div ((SLength + 2) * 75 + (ClearsizePlusStartEND * 9));
     Wide := mult * 8;
     Narrow := Mult * 3;
  END
  ELSE
  IF NOT TryRatio(20,8) then
  IF NOT TryRatio(16,6) then
  IF NOT TryRatio(13,5) then
  IF NOT TryRatio(10,4) then
  IF NOT TryRatio(8,3) then
  IF NOT TryRatio(6,2) then
  IF NOT TryRatio(5,2) then
  IF NOT TryRatio(3,1) then
  BEGIN
    Wide := 2; Narrow := 1;
  END;
    Leadin :=  UseWidth -  (((2 * Wide) + (3 * Narrow))  * SLength) - 8 * Narrow{start& END Symbols};
    Leadin := (Leadin + Narrow)  div (2 * Narrow);
    Height := UseHeight;
    StartPoint := 0;
    {space at start}
    if Leadin > 0 then
    for LI := 1 to Leadin do PrintBar(Sender,false,False);
    {Lead In Symbol}

    PrintBar(Sender,true,false);
    PrintBar(Sender,false,false);
    PrintBar(Sender,true,false);
    PrintBar(Sender,false,false);
    si := 1;
    REPEAT
     BarChar(s[SI],s[SI + 1]);
     SI := SI + 2;
    UNTIL (SI > SLength);
        {Finish Symbol}
    PrintBar(Sender,true,true);
    PrintBar(Sender,false,false);
    PrintBar(Sender,true,false);
    {space at END}
    if Leadin > 1 then
    for LI := 1 to (Leadin - 1) do PrintBar(Sender,false,False);
{    Guardbars}
    Sender.pen.color := FBarColor;
    Sender.Brush.color := FBarColor;
    Sender.Rectangle(startX + Leadin * Narrow,StartY,
    startX  + (Leadin) * Narrow + (((2 * Wide) + (3 * Narrow))  * SLength  + 8 * NARROW), StartY + 2 * Narrow);
    Sender.Rectangle(startX + Leadin * Narrow,StartY + Height - 2 * narrow,
    startX  + Leadin * Narrow + (((2 * Wide) + (3 * Narrow))  * SLength) + 8 * NARROW, StartY  + Height );
  END;


procedure PPostnet(S : string; Sender: TCanvas; pnSize : integer);

var
SI : integer;
DarkWidth, LightWIdth : integer;
HighHeight,LowHeight : integer;
CorrectionTotal       : integer;

PROCEDURE  printbar(Sender : TCanvas; drk, HighBar : boolean); {Uses global vars so all procs can call}
var Barwidth : integer;
BEGIN

  with  Sender do
  BEGIN
  if drk then Pen.Color := FBarColor else  Pen.Color := Self.color;
  if drk then  Brush.Color := FBarColor else Brush.Color := Self.color;
  if drk then Barwidth := DarkWidth else BarWidth := LightWidth;
  if Highbar then
  Rectangle(StartPOint + StartX,0+ StartY,StartPOint + BarWidth + StartX,HighHeight + StartY)
  ELSE
  BEGIN
  Rectangle(StartPOint + StartX,0+ StartY + HighHeight - LowHeight,StartPOint + BarWidth + StartX,HighHeight + StartY);
  Pen.Color := Self.color;
  Brush.Color := Self.color;
  Rectangle(StartPOint + StartX,0+ StartY ,StartPOint + BarWidth + StartX,HighHeight - Lowheight + StartY);
  END;
  StartPoint := StartPOint + BarWidth;
  END
END;





PROCEDURE barchar(ch : char);
var
    i : integer;