frxbarcod.pas

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

unit frxBarcod;

{
Barcode Component
Version 1.25 (15.05.2003)
Copyright 1998-2003 Andreas Schmidt and friends
Adapted to FR:Alexander Tzyganenko

for use with Delphi 1-7
Delphi 1 not tested; better use Delphi 2 (or higher)

Freeware
Feel free to distribute the component as
long as all files are unmodified and kept together.

I'am not responsible for wrong barcodes.

bug-reports, enhancements:
mailto:[e-mail] or [e-mail]

please tell me wich version you are using, when mailing me.

get latest version from
http://members.tripod.de/AJSchmidt/index.html
http://mitglied.lycos.de/AJSchmidt/fbarcode.zip

many thanx and geetings to
Nikolay Simeonov, Wolfgang Koranda, Norbert Waas,
Richard Hugues, Olivier Guilbaud, Berend Tober, Jan Tungli,
Mauro Lemes, Norbert Kostka, Frank De Prins, Shane O'Dea,
Daniele Teti, Ignacio Trivino, Samuel J. Comstock, Roberto Parola,
Stefano Torricella and Mariusz Mialkon.

i use tabs:1 tab = 3 spaces

History:
----------------------------------------------------------------------
Version 1.0:
-initial release
Version 1.1:
-more comments
-changed function Code_93Extended (now correct ?)
Version 1.2:
-Bugs (found by Nikolay Simeonov) removed
Version 1.3:
-EAN8/EAN13 added by Wolfgang Koranda ([e-mail])
Version 1.4:
-Bug (found by Norbert Waas) removed
  Component must save the Canvas-properties Font,Pen and Brush
Version 1.5:
-Bug (found by Richard Hugues) removed
  Last line of barcode was 1 Pixel too wide
Version 1.6:
-new read-only property 'Width'
Version 1.7
-check for numeric barcode types
-compatible with Delphi 1 (i hope)
Version 1.8
-add Color and ColorBar properties
Version 1.9
-Code 128 C added by Jan Tungli
Version 1.10
-Bug in Code 39 Character I removed
Version 1.11 (06.07.1999)
-additional Code Types
  CodeUPC_A,
  CodeUPC_E0,
  CodeUPC_E1,
  CodeUPC_Supp2,
  CodeUPC_Supp5
  by Jan Tungli
Version 1.12 (13.07.1999)
-improved ShowText property by Mauro Lemes
  you must change your applications due changed interface of TBarcode.
Version 1.13 (23.07.1999)
-additional Code Types
  CodeEAN128A,
  CodeEAN128B,
  CodeEAN128C
  (support by Norbert Kostka)
-new property 'CheckSumMethod'
Version 1.14 (29.07.1999)
-checksum for EAN128 by Norbert Kostka
-bug fix for EAN128C
Version 1.15 (23.09.1999)
-bug fix for Code 39 with checksum by Frank De Prins
Version 1.16 (10.11.1999)
-width property is now writable (suggestion by Shane O'Dea)
Version 1.17 (27.06.2000)
-new OnChange property
-renamed TBarcode to TAsBarcode to avoid name conflicts
Version 1.18 (25.08.2000)
-some speed improvements (Code 93 and Code 128)
Version 1.19 (27.09.2000)
  (thanks to Samuel J. Comstock)
-origin of the barcode (left upper edge) is moved so that
  the barcode stays always on the canvas
-new (read only) properties 'CanvasWidth' and 'CanvasHeight' gives you
  the size of the resulting image.
-a wrapper class for Quick Reports is now available.
Version 1.20 (13.09.2000)
-Assign procedure added
-support for scaling barcode to Printer (see Demo)
Version 1.21 (19.07.2001)
  (thanks to Roberto Parola)
-new properties ShowTextFont and ShowTextPosition
Version 1.22 (26.10.2001)
-Code 128 Symbol #12 (=comma) fixed (thanks to Stefano Torricella)
Version 1.23 (13.11.2002)
-UPC_E0 and UPC_E1 stopcodes fixed (thanks to Duo Dreamer)
Version 1.24 (04.12.2002)
-Bugfix for Code93 Extended
Version 1.25 (15.05.2003)
-fixed a bug in procedure Assign (thanks to Mariusz Mialkon)

Todo (missing features)
-----------------------

-more CheckSum Methods
-user defined barcodes
-checksum event (fired when the checksum is calculated)
-rename the unit name (from 'barcode' to 'fbarcode') to avoid name conflicts
-I'am working on PDF417 barcode (has anybody some technical information about PDF417
  or a PDF417 reader ?)

Known Bugs
---------
-Top and Left properties must be set at runtime.
-comments not compatible with Delphi 1
}

interface

uses
  WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TfrxBarcodeType =
  (
  bcCode_2_5_interleaved,
  bcCode_2_5_industrial,
  bcCode_2_5_matrix,
  bcCode39,
  bcCode39Extended,
  bcCode128A,
  bcCode128B,
  bcCode128C,
  bcCode93,
  bcCode93Extended,
  bcCodeMSI,
  bcCodePostNet,
  bcCodeCodabar,
  bcCodeEAN8,
  bcCodeEAN13,
  bcCodeUPC_A,
  bcCodeUPC_E0,
  bcCodeUPC_E1,
  bcCodeUPC_Supp2, { UPC 2 digit supplemental }
  bcCodeUPC_Supp5, { UPC 5 digit supplemental }
  bcCodeEAN128A,
  bcCodeEAN128B,
  bcCodeEAN128C
  );

  TfrxBarLineType = (white, black, black_half); {for internal use only}
  { black_half means a black line with 2/5 height (used for PostNet) }

  TfrxCheckSumMethod =
  (
  csmNone,
  csmModulo10
  );

  TfrxBarcode = class(TComponent)
  private
    FAngle:Double;
    FColor:TColor;
    FColorBar:TColor;
    FCheckSum:Boolean;
    FCheckSumMethod:TfrxCheckSumMethod;
    FHeight:Integer;
    FLeft:Integer;
    FModul:Integer;
    FRatio:Double;
    FText:String;
    FTop:Integer;
    FTyp:TfrxBarcodeType;
    modules:array[0..3] of ShortInt;

    procedure DoLines(data:String; Canvas:TCanvas);
    procedure OneBarProps(code:Char; var Width:Integer; var lt:TfrxBarLineType);
    function SetLen(pI:Byte):String;
    function Code_2_5_interleaved:String;
    function Code_2_5_industrial:String;
    function Code_2_5_matrix:String;
    function Code_39:String;
    function Code_39Extended:String;
    function Code_128:String;
    function Code_93:String;
    function Code_93Extended:String;
    function Code_MSI:String;
    function Code_PostNet:String;
    function Code_Codabar:String;
    function Code_EAN8:String;
    function Code_EAN13:String;
    function Code_UPC_A:String;
    function Code_UPC_E0:String;
    function Code_UPC_E1:String;
    function Code_Supp5:String;
    function Code_Supp2:String;

    procedure MakeModules;
    function GetWidth:integer;
    function DoCheckSumming(const data:string):string;
    function MakeData:string;
  public
    constructor Create(Owner:TComponent); override;
    procedure Assign(Source:TPersistent);override;

    procedure DrawBarcode(Canvas:TCanvas; ARect:TRect; ShowText:Boolean);
  published
    property Text:string read FText write FText;
    property Modul:integer read FModul write FModul;
    property Ratio:Double read FRatio write FRatio;
    property Typ:TfrxBarcodeType read FTyp write FTyp;
    property Checksum:boolean read FCheckSum write FCheckSum;
    property CheckSumMethod:TfrxCheckSumMethod read FCheckSumMethod write FCheckSumMethod;
    property Angle:double read FAngle write FAngle;
    property Width:integer read GetWidth;
    property Height:Integer read FHeight write FHeight;
    property Color:TColor read FColor write FColor;
    property ColorBar:TColor read FColorBar write FColorBar;
  end;

  TBCdata = packed record
   Name:string; { Name of Barcode }
   num:Boolean; { numeric data only }
  end;

const BCdata:array[bcCode_2_5_interleaved..bcCodeEAN128C] of TBCdata =
  (
    (Name:'2_5_interleaved'; num:True),
    (Name:'2_5_industrial'; num:True),
    (Name:'2_5_matrix'; num:True),
    (Name:'Code39'; num:False),
    (Name:'Code39 Extended'; num:False),
    (Name:'Code128A'; num:False),
    (Name:'Code128B'; num:False),
    (Name:'Code128C'; num:False),
    (Name:'Code93'; num:False),
    (Name:'Code93 Extended'; num:False),
    (Name:'MSI'; num:True),
    (Name:'PostNet'; num:True),
    (Name:'Codebar'; num:False),
    (Name:'EAN8'; num:True),
    (Name:'EAN13'; num:True),
    (Name:'UPC_A'; num:True),
    (Name:'UPC_E0'; num:True),
    (Name:'UPC_E1'; num:True),
    (Name:'UPC Supp2'; num:True),
    (Name:'UPC Supp5'; num:True),
    (Name:'EAN128A'; num:False),
    (Name:'EAN128B'; num:False),
    (Name:'EAN128C'; num:True)
  );

implementation

function CheckSumModulo10(const data:string):string;
        var i,fak,sum:Integer;
begin
        sum:= 0;
        fak:= Length(data);
        for i:=1 to Length(data) do
        begin
                if (fak mod 2) = 0 then
                        sum:= sum+(StrToInt(data[i])*1)
                else
                        sum:= sum+(StrToInt(data[i])*3);
                dec(fak);
        end;
        if (sum mod 10) = 0 then
                result:= data+'0'
        else
                result:= data+IntToStr(10-(sum mod 10));
end;

procedure Assert(Cond:Boolean; Text:String);
begin
  if not Cond then
    raise Exception.Create(Text);
end;

{
  converts a string from '321' to the internal representation '715'
  i need this function because some pattern tables have a different
  format:

  '00111'
  converts to '05161'
}
function Convert(const s:string):string;
var
  i, v:integer;
begin
  Result:= s; { same Length as Input-string }
  for i:=1 to Length(s) do
  begin
    v:= ord(s[i])-1;

    if odd(i) then
      Inc(v, 5);
    Result[i]:= Chr(v);
  end;
end;

(*
 * Berechne die Quersumme aus einer Zahl x
 * z.B.:Quersumme von 1234 ist 10
 *)
function quersumme(x:integer):integer;
var
  sum:integer;
begin
  sum:= 0;

  while x > 0 do
  begin
    sum:= sum+(x mod 10);
    x:= x div 10;
  end;
  result:= sum;
end;

{
  Rotate a Point by Angle 'alpha'
}
function Rotate2D(p:TPoint; alpha:double):TPoint;
var
  sinus, cosinus:Extended;
begin
  sinus:= sin(alpha);
  cosinus:= cos(alpha);
  result.x:= Round(p.x*cosinus+p.y*sinus);
  result.y:= Round(-p.x*sinus+p.y*cosinus);
end;

{
  Move Point "a" by Vector "b"
}
function Translate2D(a, b:TPoint):TPoint;
begin
  result.x:= a.x+b.x;
  result.y:= a.y+b.y;
end;

{
  Move the orgin so that when point is rotated by alpha, the rect
  between point and orgin stays in the visible quadrant.
}
function TranslateQuad2D(const alpha:double; const orgin, point:TPoint):TPoint;
var
   alphacos:Extended;
   alphasin:Extended;
   moveby:TPoint;
begin
   alphasin:= sin(alpha);
   alphacos:= cos(alpha);

   if alphasin >= 0 then
   begin
      if alphacos >= 0 then
      begin
         // 1. Quadrant
         moveby.x:= 0;
         moveby.y:= Round(alphasin*point.x);
      end
      else
      begin
         // 2. Quadrant
         moveby.x:=-Round(alphacos*point.x);
         moveby.y:= Round(alphasin*point.x-alphacos*point.y);
      end;
   end
   else
   begin
      if alphacos >= 0 then
      begin
         // 4. quadrant
         moveby.x:=-Round(alphasin*point.y);
         moveby.y:= 0;
      end
      else
      begin
         // 3. quadrant
         moveby.x:=-Round(alphacos*point.x)-Round(alphasin*point.y);
         moveby.y:=-Round(alphacos*point.y);
      end;
   end;
   Result:= Translate2D(orgin, moveby);
end;

constructor TfrxBarcode.Create(Owner:TComponent);
begin
  inherited Create(owner);
  FAngle:= 0.0;
  FRatio:= 2.0;
  FModul:= 1;
  FTyp:= bcCodeEAN13;
  FCheckSum:= FALSE;
  FCheckSumMethod:= csmModulo10;
  FColor:= clWhite;
  FColorBar:= clBlack;
end;

procedure TfrxBarcode.Assign(Source:TPersistent);
var
   BSource:TfrxBarcode;
begin
   if Source is TfrxBarcode then
   begin
      BSource:= TfrxBarcode(Source);
      FHeight:= BSource.FHeight;
      FText:= BSource.FText;
      FTop:= BSource.FTop;
      FLeft:= BSource.FLeft;
      FModul:= BSource.FModul;
      FRatio:= BSource.FRatio;
      FTyp:= BSource.FTyp;
      FCheckSum:= BSource.FCheckSum;
      FAngle:= BSource.FAngle;
      FColor:= BSource.FColor;
      FColorBar:= BSource.FColorBar;
      FCheckSumMethod:= BSource.FCheckSumMethod;
   end;
end;

{
calculate the width and the linetype of a sigle bar

  Code Line-Color Width Height
------------------------------------------------------------------
  '0' white 100% full
  '1' white 100%*Ratio full
  '2' white 150%*Ratio full
  '3' white 200%*Ratio full
  '5' black 100% full
  '6' black 100%*Ratio full
  '7' black 150%*Ratio full
  '8' black 200%*Ratio full
  'A' black 100% 2/5 (used for PostNet)
  'B' black 100%*Ratio 2/5 (used for PostNet)
  'C' black 150%*Ratio 2/5 (used for PostNet)
  'D' black 200%*Ratio 2/5 (used for PostNet)
}
procedure TfrxBarcode.OneBarProps(code:char; var Width:integer; var lt:TfrxBarLineType);
begin
  case code of
    '0':begin width:= modules[0]; lt:= white; end;
    '1':begin width:= modules[1]; lt:= white; end;
    '2':begin width:= modules[2]; lt:= white; end;
    '3':begin width:= modules[3]; lt:= white; end;

    '5':begin width:= modules[0]; lt:= black; end;
    '6':begin width:= modules[1]; lt:= black; end;
    '7':begin width:= modules[2]; lt:= black; end;
    '8':begin width:= modules[3]; lt:= black; end;

    'A':begin width:= modules[0]; lt:= black_half; end;
    'B':begin width:= modules[1]; lt:= black_half; end;
    'C':begin width:= modules[2]; lt:= black_half; end;
    'D':begin width:= modules[3]; lt:= black_half; end;
  else
    begin
   {something went wrong:-( }
   {mistyped pattern table}
    raise Exception.CreateFmt('%s:internal Error', [self.ClassName]);
    end;
  end;
end;

function TfrxBarcode.MakeData:string;