barcode.pas

一个很好的条形码控件

unit Barcode;

{
Barcode Component
Version 1.21 (19.07.2001)
Copyright 1998-2001 Andreas Schmidt and friends

for use with Delphi 1/2/3/4/5
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


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 and
Roberto Parola.

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



Todo (missing features)
-----------------------
- I'am working on PDF417 barcode (has anybody some technical information about PDF417
  or a PDF417 reader ?)
- 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





Known Bugs
---------
- Top and Left properties must be set at runtime.

}



interface

uses
  Classes, Graphics;

type
  TBarcodeType =
  (
  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
  );


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


  TBarcodeOption = (bcoNone, bcoCode, bcoTyp, bcoBoth); { Type of text to show }

// Additions from Roberto Parola to improve the text output
  TShowTextPosition =
  (
    stpTopLeft,
    stpTopRight,
    stpTopCenter,
    stpBottomLeft,
    stpBottomRight,
    stpBottomCenter
  );
//


  TCheckSumMethod =
  (
  csmNone,
  csmModulo10
  );


  TAsBarcode = class(TComponent)
  private
    { Private-Deklarationen }
    FHeight : integer;
    FText  : string;
    FTop    : integer;
    FLeft   : integer;
    FModul  : integer;
    FRatio  : double;
    FTyp    : TBarcodeType;
    FCheckSum:boolean;
    FShowText:TBarcodeOption;
    FAngle  : double;
    FColor  : TColor;
    FColorBar:TColor;
    FCheckSumMethod : TCheckSumMethod;
      FOnChange : TNotifyEvent;


    modules:array[0..3] of shortint;
    FShowTextFont: TFont;
    FShowTextPosition: TShowTextPosition;


    procedure OneBarProps(code:char; var Width:integer; var lt:TBarLineType);

    procedure DoLines(data:string; Canvas:TCanvas);

    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;

    function GetTypText:string;
    procedure MakeModules;

    procedure SetModul(v:integer);

    function GetWidth : integer;
    procedure SetWidth(Value :integer);

    function DoCheckSumming(const data : string):string;
      procedure SetRatio(const Value: Double);
      procedure SetTyp(const Value: TBarcodeType);
      procedure SetAngle(const Value: Double);
      procedure SetText(const Value: string);
      procedure SetShowText(const Value: TBarcodeOption);
      procedure SetTop(const Value: Integer);
      procedure SetLeft(const Value: Integer);
      procedure SetCheckSum(const Value: Boolean);
    procedure SetHeight(const Value: integer);
    function GetCanvasHeight: Integer;
    function GetCanvasWidth: Integer;
// Additions from Roberto Parola to improve the text output
    procedure SetShowTextFont(const Value: TFont);
    procedure SetShowTextPosition(const Value: TShowTextPosition);

  protected
    { Protected-Deklarationen }
    function MakeData : string;
      procedure DoChange; virtual;

  public
    { Public-Deklarationen }
    constructor Create(Owner:TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent);override;

    procedure DrawBarcode(Canvas:TCanvas);
    procedure DrawText(Canvas:TCanvas);
    property CanvasHeight :Integer read GetCanvasHeight;
    property CanvasWidth :Integer read GetCanvasWidth;
  published
    { Published-Deklarationen }
   { Height of Barcode (Pixel)}
    property Height : integer read FHeight write SetHeight;
    property Text   : string read FText write SetText;
    property Top    : Integer read FTop write SetTop;
    property Left   : Integer read FLeft write SetLeft;
   { Width of the smallest line in a Barcode }
    property Modul  : integer read FModul  write SetModul;
    property Ratio  : Double read FRatio write SetRatio;
    property Typ    : TBarcodeType read FTyp write SetTyp default bcCode_2_5_interleaved;
   { build CheckSum ? }
    property Checksum:boolean read FCheckSum write SetCheckSum default FALSE;
    property CheckSumMethod:TCheckSumMethod read FCheckSumMethod write FCheckSumMethod default csmModulo10;

   { 0 - 360 degree }
    property Angle  :double read FAngle write SetAngle;

    property ShowText:TBarcodeOption read FShowText write SetShowText default bcoNone;
    property ShowTextFont: TFont read FShowTextFont write SetShowTextFont;
    property ShowTextPosition: TShowTextPosition read FShowTextPosition write SetShowTextPosition default stpTopLeft;
    property Width : integer read GetWidth write SetWidth stored False;
    property Color:TColor read FColor write FColor default clWhite;
    property ColorBar:TColor read FColorBar write FColorBar default clBlack;
      property OnChange:TNotifyEvent read FOnChange write FOnChange;
  end;

procedure Register;

implementation


{$ifdef WIN32}
  {$R barcode.d32}
{$else}
  {$R barcode.d16}
{$endif}


uses WinProcs, WinTypes, SysUtils, bcchksum,
   math;


{$DEFINE ASSERT_SUPPORTED}

{$IFDEF VER80}
{$UNDEF ASSERT_SUPPORTED}
{$ENDIF}
{$IFDEF VER90}
{$UNDEF ASSERT_SUPPORTED}
{$ENDIF}
{$IFDEF VER100}
{$UNDEF ASSERT_SUPPORTED}
{$ENDIF}
{$IFDEF VER110}
{$UNDEF ASSERT_SUPPORTED}
{$ENDIF}


type
  TBCdata = 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:True),
    (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)
  );

{$ifndef WIN32}
function Trim(const S: string): string; export;
{ Removes leading and trailing whitespace from s}
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] <= ' ') do Inc(I);
  if I > L then Result := '' else
  begin
   while S[L] <= ' ' do Dec(L);
   Result := Copy(S, I, L - I + 1);
  end;
end;
{$endif}



{
  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);
*)
  { twice as fast than calc sin() and cos() }
  SinCos(alpha, sinus, cosinus);

  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;


procedure Rotate2Darray(p:array of TPoint; alpha:double);
var
   i : Integer;
begin
   for i:=Low(p) to High(p) do
      p[i] := Rotate2D(p[i], alpha);
end;

procedure Translate2Darray(p:array of TPoint; shift:TPoint);
var
   i : Integer;
begin
   for i:=Low(p) to High(p) do
      p[i] := Translate2D(p[i], shift);
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
   SinCos(alpha, alphasin, alphacos);
   {
   SinCos is twice as fast as:
   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 TAsBarcode.Create(Owner:TComponent);
begin
  inherited Create(owner);
  FAngle := 0.0;
  FRatio := 2.0;
  FModul := 1;
  FTyp   := bcCodeEAN13;
  FCheckSum := FALSE;
  FCheckSumMethod := csmModulo10;
  FShowText := bcoNone;
  FColor    := clWhite;
  FColorBar := clBlack;
  FShowTextFont := TFont.Create;
  FShowTextPosition := stpTopLeft;
end;

destructor TAsBarcode.Destroy;
begin
  FShowTextFont.Free;
  inherited;
end;

procedure TAsBarcode.Assign(Source: TPersistent);
var
   BSource : TAsBarcode;
begin
   if Source is TAsBarcode then
   begin
      BSource    := TAsBarcode(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;
      FShowText  := BSource.FShowText;
      FAngle     := BSource.FAngle;
      FColor     := BSource.FColor;
      FColorBar  := BSource.FColorBar;
      FCheckSumMethod := BSource.FCheckSumMethod;
      FOnChange  := BSource.FOnChange;
   end;
end;


function TAsBarcode.GetTypText:string;
begin
  result := BCdata[FTyp].Name;
end;



{ set Modul Width  }
procedure TAsBarcode.SetModul(v:integer);