frxbarcod.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

begin
  result:= tabelle_cb[Find_Codabar('A')].data+'0';
  for i:=1 to Length(FText) do
  begin
    idx:= Find_Codabar(FText[i]);
    result:= result+tabelle_cb[idx].data+'0';
  end;
  result:= result+tabelle_cb[Find_Codabar('B')].data;
end;

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

{Assist function}
function TfrxBarcode.SetLen(pI:byte):string;
begin
  Result:= StringOfChar('0', pI-Length(FText))+FText;
end;

function TfrxBarcode.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 TfrxBarcode.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 TfrxBarcode.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 TfrxBarcode.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 TfrxBarcode.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 TfrxBarcode.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 TfrxBarcode.DoLines(data:string; Canvas:TCanvas);

var i:integer;
  lt:TfrxBarLineType;
  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 TfrxBarcode.DrawBarcode(Canvas:TCanvas; ARect:TRect; ShowText:Boolean);
const
  TxtHeight = 14;
var
  data:string;
  w, h, BarWidth:Integer;
  EMF:TMetafile;
  EMFCanvas:TMetafileCanvas;
  Zoom:Extended;

  function CreateRotatedFont(Font:TFont; Angle:Integer):HFont;
  var
    F:TLogFont;
  begin
    GetObject(Font.Handle, SizeOf(TLogFont), @F);
    F.lfEscapement:= Angle * 10;
    F.lfOrientation:= Angle * 10;
    Result:= CreateFontIndirect(F);
  end;

  procedure TextOutR(x, x1, x2:Integer; s:String);
  begin
    with EMFCanvas do
      case Round(FAngle) of
        90:
          begin
            FillRect(Rect(w-TxtHeight, h-x1, w, h-x2-1));
            TextOut(w-TxtHeight, h-x, s);
          end;
        180:
          begin
            FillRect(Rect(w-x1, 0, w-x2-1, TxtHeight+2));
            TextOut(w-x, TxtHeight, s);
          end;
        270:
          begin
            FillRect(Rect(0, x1, TxtHeight, x2+1));
            TextOut(TxtHeight, x, s);
          end;
        else
          begin
            FillRect(Rect(x1, h-TxtHeight-2, x2+1, h));
            TextOut(x, h-TxtHeight, s);
          end;
      end;
  end;

  procedure OutText;
  var
    TxtWidth:Integer;
    FontHandle, OldFontHandle:HFont;
  begin
    with EMFCanvas do
    begin
      Font.Name:= 'Arial';
      Font.Size:= 9;
      FontHandle:= CreateRotatedFont(Font, Round(FAngle));
      OldFontHandle:= SelectObject(Handle, FontHandle);
      Brush.Color:= Color;
      SetBkMode(Handle, Transparent);

      case FTyp of
        bcCodeEAN8:// 8 digits, 4+4
          begin
            TextOutR(3, 3, 30, Copy(FText, 1, 4));
            TextOutR(35, 35, BarWidth-4, Copy(FText, 5, 4));
          end;
        bcCodeEAN13:// 13 digits, 1+6+6 or 12 digits, 6+6
          begin
            if FText[1]<>'0' then
              TextOutR(-8,-8,-2, Copy(FText, 1, 1));
            TextOutR(3, 3, 44, Copy(FText, 2, 6));
            TextOutR(49, 49, BarWidth-4, Copy(FText, 8, 6));
          end;
        bcCodeUPC_A:// 12 digits, 1+5+5+1
          begin
            TextOutR(-8,-8,-2, Copy(FText, 1, 1));
            TextOutR(10, 10, 44, Copy(FText, 2, 5));
            TextOutR(49, 49, 83, Copy(FText, 7, 5));
            TextOutR(BarWidth+1, BarWidth+1, BarWidth+8, Copy(FText, 12, 1));
          end;
        bcCodeUPC_E0,
        bcCodeUPC_E1:// 7 digits, 6+1
          begin
            TextOutR(3, 3, 44, Copy(FText, 1, 6));
            TextOutR(BarWidth+1, BarWidth+1, BarWidth+8, Copy(FText, 7, 1));
          end;
        else
          begin
            TxtWidth:= TextWidth(FText);
            TextOutR((BarWidth-TxtWidth) div 2, 0, BarWidth, FText);
          end;
      end;

      SelectObject(Handle, OldFontHandle);
      DeleteObject(FontHandle);
    end;
  end;

begin
  data:= MakeData;
  BarWidth:= Width;

  FLeft:= 0;
  FTop:= 0;

  if (FAngle = 0) or (FAngle = 180) then
  begin
    Zoom:= (ARect.Right-ARect.Left) / BarWidth;
    w:= BarWidth;
    h:= ARect.Bottom-ARect.Top;
    h:= Round(h / Zoom);
    if FTyp in [bcCodeEAN8, bcCodeEAN13, bcCodeUPC_A, bcCodeUPC_E0, bcCodeUPC_E1] then
    begin
      FHeight:= h-TxtHeight div 2;
      if FAngle = 180 then
        FTop:= (TxtHeight+2) div 2;
    end
    else
    begin
      FHeight:= h-TxtHeight-2;
      if FAngle = 180 then
        FTop:= TxtHeight+2;
    end;
  end
  else
  begin
    Zoom:= (ARect.Bottom-ARect.Top) / BarWidth;
    w:= ARect.Right-ARect.Left;
    h:= BarWidth;
    w:= Round(w / Zoom);
    if FTyp in [bcCodeEAN8, bcCodeEAN13, bcCodeUPC_A, bcCodeUPC_E0, bcCodeUPC_E1] then
    begin
      FHeight:= w-TxtHeight div 2;
      if FAngle = 270 then
        FLeft:= (TxtHeight+2) div 2;
    end
    else
    begin
      FHeight:= w-TxtHeight-2;
      if FAngle = 270 then
        FLeft:= TxtHeight+2;
    end;
  end;

  EMF:= TMetafile.Create;
  EMF.Width:= w;
  EMF.Height:= h;

  try
    EMFCanvas:= TMetafileCanvas.Create(EMF, 0);

    try
      DoLines(data, EMFCanvas);
      if ShowText then
        OutText;
    finally
      EMFCanvas.Free;
    end;

    Canvas.StretchDraw(ARect, EMF);
  finally
    EMF.Free;
  end;
end;

end.