barcode.pas

说明： 支持D3-D7 TBARCODE 条码控件

unit Barcode;

{
Barcode Component
Version 1.15 (23.09.1999)
Copyright 1998-99 Andreas Schmidt and friends

Freeware

for use with Delphi 1/2/3/4


this component is for private use only !
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 and Frank De Prins.

i use tabs:  1 tab = 3 spaces


Diese Komponente darf nur in privaten Projekten verwendet werden.
Die Weitergabe von ver鋘derte Dateien ist nicht zul鋝sig.
F黵 die Korrektheit der erzeugten Barcodes kann keine Garantie
黚ernommen werden.
Anregungen, Bug-Reports, Danksagungen an:
mailto:[e-mail]



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


Todo (missing features)
-----------------------
- Wrapper Class for Quick Reports
- I'am working on PDF417 barcode (has anybody some technical information about PDF417
  or a PDF417 reader ?)
- more CheckSum Methods


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

}



interface

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

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

  TCheckSumMethod =
  (
  csmNone,
  csmModulo10
  );


	TBarcode = 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;


		modules:array[0..3] of shortint;


		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;

		function DoCheckSumming(const data : string):string;

	protected
	  { Protected-Deklarationen }
		function MakeData : string;

	public
	  { Public-Deklarationen }
		constructor Create(Owner:TComponent); override;
		procedure DrawBarcode(Canvas:TCanvas);
		procedure DrawText(Canvas:TCanvas);
	published
	  { Published-Deklarationen }
	 { Height of Barcode (Pixel)}
		property Height : integer read FHeight write FHeight;
		property Text   : string  read FText   write FText;
		property Top    : integer read FTop    write FTop;
		property Left   : integer read FLeft   write FLeft;
	 { Width of the smallest line in a Barcode }
		property Modul  : integer read FModul  write SetModul;
		property Ratio  : double  read FRatio  write FRatio;
		property Typ    : TBarcodeType read FTyp write FTyp default bcCode_2_5_interleaved;
	 { build CheckSum ? }
		property Checksum:boolean read FCheckSum write FCheckSum default FALSE;
		property CheckSumMethod:TCheckSumMethod read FCheckSumMethod write FCheckSumMethod default csmModulo10;

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

		property ShowText:TBarcodeOption read FShowText write FShowText default bcoNone;
		property Width : integer read GetWidth;
		property Color:TColor read FColor write FColor default clWhite;
		property ColorBar:TColor read FColorBar write FColorBar default clBlack;

	end;

procedure Register;

implementation

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


uses bcchksum;


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(s:string):string;
var
	i, v : integer;
	t : string;
begin
	t := '';
	for i:=1 to Length(s) do
	begin
		v := ord(s[i]) - 1;

		if odd(i) then
			Inc(v, 5);
		t := t + Chr(v);
	end;
	Convert := t;
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;





constructor TBarcode.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;

end;


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



{ set Modul Width  }
procedure TBarcode.SetModul(v:integer);
begin
	if (v >= 1) and (v < 50) then
		FModul := v;
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 TBarcode.OneBarProps(code:char; var Width:integer; var lt:TBarLineType);
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 TBarcode.MakeData : string;
var
	i : integer;
begin
  {calculate the with of the different lines (modules)}
	MakeModules;


  {numeric barcode type ?}
	if BCdata[Typ].num then
	begin
	 FText := Trim(FText); {remove blanks}
		for i := 1 to Length(Ftext) do
			if (FText[i] > '9') or (FText[i] < '0') then
				raise Exception.Create('Barcode must be numeric');
	end;