barcode.pas

barcode component The sourcecode does not rely on any language specific features. It will prob

   StringOfChar()

  Result := FText;
  while Length(Result) < pI do
    Result:='0'+Result;
}
end;



function TAsBarcode.Code_UPC_A:string;
var
  i : integer;
  tmp : String;
begin
  FText := SetLen(12);
  if FCheckSum then tmp:=DoCheckSumming(copy(FText,1,11));
  if FCheckSum then FText:=tmp else tmp:=FText;
  result := '505';   {Startcode}
  for i:=1 to 6 do
    result := result + tabelle_EAN_A[tmp[i]];
  result := result + '05050';   {Trennzeichen}
  for i:=7 to 12 do
    result := result + tabelle_EAN_C[tmp[i]];
  result := result + '505';   {Stopcode}
end;


{UPC E Parity Pattern Table , Number System 0}
const tabelle_UPC_E0:array['0'..'9', 1..6] of char =
  (
  ('E', 'E', 'E', 'o', 'o', 'o' ),    { 0 }
  ('E', 'E', 'o', 'E', 'o', 'o' ),    { 1 }
  ('E', 'E', 'o', 'o', 'E', 'o' ),    { 2 }
  ('E', 'E', 'o', 'o', 'o', 'E' ),    { 3 }
  ('E', 'o', 'E', 'E', 'o', 'o' ),    { 4 }
  ('E', 'o', 'o', 'E', 'E', 'o' ),    { 5 }
  ('E', 'o', 'o', 'o', 'E', 'E' ),    { 6 }
  ('E', 'o', 'E', 'o', 'E', 'o' ),    { 7 }
  ('E', 'o', 'E', 'o', 'o', 'E' ),    { 8 }
  ('E', 'o', 'o', 'E', 'o', 'E' )     { 9 }
  );

function TAsBarcode.Code_UPC_E0:string;
var i,j : integer;
   tmp : String;
   c   : char;
begin
  FText := SetLen(7);
  tmp:=DoCheckSumming(copy(FText,1,6));
  c:=tmp[7];
  if FCheckSum then FText:=tmp else tmp := FText;
  result := '505';   {Startcode}
  for i:=1 to 6 do
  begin
    if tabelle_UPC_E0[c,i]='E' then
    begin
      for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
    end
    else
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end;
  end;
  result := result + '050505';   {Stopcode}
end;

function TAsBarcode.Code_UPC_E1:string;
var i,j : integer;
   tmp : String;
   c   : char;
begin
  FText := SetLen(7);
  tmp:=DoCheckSumming(copy(FText,1,6));
  c:=tmp[7];
  if FCheckSum then FText:=tmp else tmp := FText;
  result := '505';   {Startcode}
  for i:=1 to 6 do
  begin
    if tabelle_UPC_E0[c,i]='E' then
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end
    else
    begin
      for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
    end;
  end;
  result := result + '050505';   {Stopcode}
end;

{assist function}
function getSupp(Nr : String) : String;
var i,fak,sum : Integer;
      tmp   : String;
begin
  sum := 0;
  tmp := copy(nr,1,Length(Nr)-1);
  fak := Length(tmp);
  for i:=1 to length(tmp) do
  begin
    if (fak mod 2) = 0 then
      sum := sum + (StrToInt(tmp[i])*9)
    else
      sum := sum + (StrToInt(tmp[i])*3);
    dec(fak);
  end;
  sum:=((sum mod 10) mod 10) mod 10;
  result := tmp+IntToStr(sum);
end;

function TAsBarcode.Code_Supp5:string;
var i,j : integer;
   tmp : String;
   c   : char;
begin
  FText := SetLen(5);
  tmp:=getSupp(copy(FText,1,5)+'0');
  c:=tmp[6];
  if FCheckSum then FText:=tmp else tmp := FText;
  result := '506';   {Startcode}
  for i:=1 to 5 do
  begin
    if tabelle_UPC_E0[c,(6-5)+i]='E' then
    begin
      for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
    end
    else
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end;
    if i<5 then result:=result+'05'; { character delineator }
  end;
end;

function TAsBarcode.Code_Supp2:string;
var i,j : integer;
   tmp,mS : String;
begin
  FText := SetLen(2);
  i:=StrToInt(Ftext);
  case i mod 4 of
    3: mS:='EE';
    2: mS:='Eo';
    1: mS:='oE';
    0: mS:='oo';
  end;
  tmp:=getSupp(copy(FText,1,5)+'0');

  if FCheckSum then FText:=tmp else tmp := FText;
  result := '506';   {Startcode}
  for i:=1 to 2 do
  begin
    if mS[i]='E' then
    begin
      for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
    end
    else
    begin
      result := result + tabelle_EAN_A[tmp[i]];
    end;
    if i<2 then result:=result+'05'; { character delineator }
  end;
end;

{---------------}




procedure TAsBarcode.MakeModules;
begin
  case Typ of
    bcCode_2_5_interleaved,
    bcCode_2_5_industrial,
    bcCode39,
    bcCodeEAN8,
    bcCodeEAN13,
    bcCode39Extended,
    bcCodeCodabar,
    bcCodeUPC_A,
    bcCodeUPC_E0,
    bcCodeUPC_E1,
    bcCodeUPC_Supp2,
    bcCodeUPC_Supp5:

    begin
      if Ratio < 2.0 then Ratio := 2.0;
      if Ratio > 3.0 then Ratio := 3.0;
    end;

    bcCode_2_5_matrix:
    begin
      if Ratio < 2.25 then Ratio := 2.25;
      if Ratio > 3.0 then Ratio := 3.0;
    end;
    bcCode128A,
    bcCode128B,
    bcCode128C,
    bcCode93,
    bcCode93Extended,
    bcCodeMSI,
    bcCodePostNet:    ;
  end;


  modules[0] := FModul;
  modules[1] := Round(FModul*FRatio);
  modules[2] := modules[1] * 3 div 2;
  modules[3] := modules[1] * 2;
end;





{
Draw the Barcode

Parameter :
'data' holds the pattern for a Barcode.
A barcode begins always with a black line and
ends with a black line.

The white Lines builds the space between the black Lines.

A black line must always followed by a white Line and vica versa.

Examples:
  '50505'   // 3 thin black Lines with 2 thin white Lines
  '606'     // 2 fat black Lines with 1 thin white Line

  '5605015' // Error


data[] : see procedure OneBarProps

}
procedure TAsBarcode.DoLines(data:string; Canvas:TCanvas);

var i:integer;
  lt : TBarLineType;
  xadd:integer;
  width, height:integer;
  a,b,c,d,     {Edges of a line (we need 4 Point because the line}
          {is a recangle}
  orgin : TPoint;
  alpha:double;
begin
  xadd := 0;
  orgin.x := FLeft;
  orgin.y := FTop;

  alpha := FAngle/180.0*pi;

  { Move the orgin so the entire barcode ends up in the visible region. }
  orgin := TranslateQuad2D(alpha,orgin,Point(Self.Width,Self.Height));

  with Canvas do begin
    Pen.Width := 1;

   for i:=1 to Length(data) do  {examine the pattern string}
    begin

      {
      input:  pattern code
      output: Width and Linetype
      }
      OneBarProps(data[i], width, lt);

      if (lt = black) or (lt = black_half) then
      begin
        Pen.Color := FColorBar;
      end
      else
      begin
        Pen.Color := FColor;
      end;
      Brush.Color := Pen.Color;

      if lt = black_half then
        height := FHeight * 2 div 5
      else
        height := FHeight;





      a.x := xadd;
      a.y := 0;

      b.x := xadd;
      b.y := height;

    {c.x := xadd+width;}
    c.x := xadd+Width-1;  {23.04.1999 Line was 1 Pixel too wide}
      c.y := Height;

    {d.x := xadd+width;}
    d.x := xadd+Width-1;  {23.04.1999 Line was 1 Pixel too wide}
      d.y := 0;

    {a,b,c,d builds the rectangle we want to draw}


    {rotate the rectangle}
      a := Translate2D(Rotate2D(a, alpha), orgin);
      b := Translate2D(Rotate2D(b, alpha), orgin);
      c := Translate2D(Rotate2D(c, alpha), orgin);
      d := Translate2D(Rotate2D(d, alpha), orgin);

    {draw the rectangle}
      Polygon([a,b,c,d]);

      xadd := xadd + width;
    end;
  end;
end;



procedure TAsBarcode.DrawBarcode(Canvas:TCanvas);
var
  data : string;
  SaveFont: TFont;
  SavePen: TPen;
  SaveBrush: TBrush;
begin
  Savefont  := TFont.Create;
  SavePen   := TPen.Create;
  SaveBrush := TBrush.Create;


  {get barcode pattern}
  data := MakeData;


  try
   {store Canvas properties}
    Savefont.Assign(Canvas.Font);
    SavePen.Assign(Canvas.Pen);
    SaveBrush.Assign(Canvas.Brush);

    DoLines(data, Canvas);    {draw the barcode}

    if FShowText <> bcoNone then
      DrawText(Canvas);   {show readable Text}


   {restore old Canvas properties}
    Canvas.Font.Assign(savefont);
    Canvas.Pen.Assign(SavePen);
    Canvas.Brush.Assign(SaveBrush);
  finally
    Savefont.Free;
    SavePen.Free;
    SaveBrush.Free;
  end;
end;


{
  draw contents and type/name of barcode
  as human readable text at the left
  upper edge of the barcode.

  main use for this procedure is testing.

  note: this procedure changes Pen and Brush
  of the current canvas.

  Modifications from Roberto Parola to improve the text output
  Its useful to print the Text (code) on the barcode, in case the pen
  doesnt read the barcode.
  I didnt implement the EAN8 and EAN13 way to print the code, because
  the first character is outside of the bound of the barcode, and this
  can cause some problems (expecially in a report)
}
procedure TAsBarcode.DrawText(Canvas:TCanvas);
var
  PosX, PosY: Integer;
  SaveFont: TFont;
begin
  with Canvas do
  begin
//    Font.Size := 5;
    {the fixed font size is a problem, if you
     use very large or small barcodes}
// then i thought well to modify it

// I know... you already did it in the DrawBarcode function, and this one is
// called only by there... but i want to be sure :)
    SaveFont := TFont.Create;
    try
      Font.Assign(ShowTextFont);
      try
        Pen.Color := Font.Color;
        Brush.Color := clWhite;


// I only consider the Text (code) position.
// As stated by Andreas Schmidt
        PosX := FLeft;
        PosY := FTop;

        if ShowTextPosition in [stpTopLeft, stpBottomLeft] then
          PosX := FLeft
        else
          if ShowTextPosition in [stpTopRight, stpBottomRight] then
            PosX := FLeft + Width - TextWidth(Text)
          else
            // i know, the last IF is useless, but i like it this way
            if ShowTextPosition in [stpTopCenter, stpBottomCenter] then
              PosX := FLeft + Trunc((Width - TextWidth(Text))/2);

        if ShowTextPosition in [stpTopLeft, stpTopCenter, stpTopRight] then
          PosY := FTop
        else
          if ShowTextPosition in [stpBottomLeft, stpBottomCenter, stpBottomRight] then
            PosY := FTop + Height - TextHeight(Text);

        if FShowText in [bcoCode, bcoBoth] then
//          TextOut(FLeft, FTop, FText);         {contents of Barcode}
          TextOut(PosX, PosY, FText);         {contents of Barcode}
        if FShowText in [bcoTyp, bcoBoth] then
          TextOut(FLeft, FTop+Round(Font.Height*2.5), GetTypText); {type/name of barcode}
      finally
        Font.Assign(SaveFont);
      end;
    finally
      SaveFont.Free;
    end;
  end;
end;


procedure TAsBarcode.DoChange;
begin
   if Assigned(FOnChange) then
      FOnChange(Self);
end;

procedure TAsBarcode.SetRatio(const Value: Double);
begin
   if Value <> FRatio then
   begin
      FRatio := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetTyp(const Value: TBarcodeType);
begin
   if Value <> FTyp then
   begin
      FTyp := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetAngle(const Value: Double);
begin
   if Value <> FAngle then
   begin
      FAngle := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetText(const Value: string);
begin
   if Value <> FText then
   begin
      FText := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetShowText(const Value: TBarcodeOption);
begin
   if Value <> FShowText then
   begin
      FShowText := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetTop(const Value: Integer);
begin
   if Value <> FTop then
   begin
      FTop := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetLeft(const Value: Integer);
begin
   if Value <> FLeft then
   begin
      FLeft := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetCheckSum(const Value: Boolean);
begin
   if Value <> FCheckSum then
   begin
      FCheckSum := Value;
      DoChange;
   end;
end;

procedure TAsBarcode.SetHeight(const Value: integer);
begin
   if Value <> FHeight then
   begin
      FHeight := Value;
      DoChange;
   end;
end;

procedure Register;
begin
  {
  there is a function to determine the page name
  independent of your language
  but i forgot it.
  could you get me a hint to avoid this hard coded string 'Extras'
  }
  RegisterComponents('Extras', [TAsBarcode]);
end;

function TAsBarcode.GetCanvasHeight: Integer;
var
  alpha :Extended;
begin
  alpha := FAngle/180.0*pi;
  Result := Round(abs(sin(alpha))*Self.Width + abs(cos(alpha))*Self.Height + 0.5); {.5 rounds up always}
end;

function TAsBarcode.GetCanvasWidth: Integer;
var
  alpha :Extended;
begin
  alpha := FAngle/180.0*pi;
  Result := Round(abs(cos(alpha))*Self.Width + abs(sin(alpha))*Self.Height + 0.5); { .5 rounds up always}
end;


procedure TAsBarcode.SetShowTextFont(const Value: TFont);
begin
  FShowTextFont.Assign(Value);
  DoChange;
end;

procedure TAsBarcode.SetShowTextPosition(const Value: TShowTextPosition);
begin
   if Value <> FShowTextPosition then
   begin
     FShowTextPosition := Value;
     DoChange;
   end;
end;

end.