rm_asbarcode.pas

这是一个功能强大

unit RM_AsBarCode;


{
Barcode Component
Version 1.27 (27.10.2004)
Copyright 1998-2004 Andreas Schmidt and friends

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)
Version 1.26 (27.05.2004)
- fixed a bug for Code93 (wrong checksum calculation for barcode with more than 14 chars)
Version 1.27 (27.10.2004)
- added Code128 Charset A control codes from 0 to 31


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
  Windows, SysUtils, math, 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
    );

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)
    );

type
  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 }
    procedure DoChange; virtual;

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

    function MakeData: string;
    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;


implementation


{$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}


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;

{$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;

(*
  not used, but left in place for future use
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;