paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-08 19:32:45 +02:00
Code Issues Packages Projects Releases Wiki Activity
d94a996d71
lazarus/components/lazreport/source/barcode.pas
mattias 06d2a8ce1a lazreport: less notes 
git-svn-id: trunk@36427 -
2012-03-29 10:12:51 +00:00

1646 lines
40 KiB
ObjectPascal
Raw Blame History

unit Barcode;
{
Barcode Component
Version 1.5 (23 Apr 1999)
Copyright 1998-99 Andreas Schmidt and friends
Freeware
for use with Delphi 2/3/4
this component is for private use only !
i'am not responsible for wrong barcodes
bug-reports, enhancements:
mailto:shmia@bizerba.de or a_j_schmidt@rocketmail.com
get latest version from
http://members.tripod.de/AJSchmidt/index.html
thanx to Nikolay Simeonov, Wolfgang Koranda, Norbert Waas,
Richard Hugues and Olivier Guilbaud.
Diese Komponente darf nur in privaten Projekten verwendet werden.
Die Weitergabe von veränderte Dateien ist nicht zulässig.
Für die Korrektheit der erzeugten Barcodes kann keine Garantie
übernommen werden.
Anregungen, Bug-Reports, Danksagungen an:
mailto:shmia@bizerba.de
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 (wkoranda@csi.com)
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'
Todo (missing features)
-----------------------
- Wrapper Class for Quick Reports
}
interface
{$I lr_vers.inc}
uses
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
);
TBarLineType = (white, black, black_half); // for internal use only
// black_half means a black line with 2/5 height (used for PostNet)
{ TBarcode }
TBarcode = class(TComponent)
private
{ Private-Deklarationen }
FHeight: integer;
FText: string;
FTop: integer;
FLeft: integer;
FModul: integer;
FRatio: double;
FTyp: TBarcodeType;
FCheckSum: boolean;
FShowText: boolean;
FAngle: double;
FCodetext: string;
modules: array[0..3] of shortint;
procedure OneBarProps(code: char; out aWidth: integer; out lt: TBarLineType);
procedure DoLines(Data: string; Canvas: TCanvas);
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 GetTypText: string;
procedure MakeModules;
procedure SetModul(v: integer);
function GetWidth: integer;
procedure SetText(AValue: string);
function CleanEANValue(const AValue: string; const ASize:Byte): string;
protected
{ Protected-Deklarationen }
function MakeData: string;
public
{ Public-Deklarationen }
constructor Create(aOwner: TComponent); override;
procedure DrawBarcode(Canvas: TCanvas);
procedure DrawText(Canvas: TCanvas);
function BarcodeTypeChecked(AType: TBarcodeType): boolean;
property CodeText: string read FCodetext write FCodeText;
published
{ Published-Deklarationen }
// Height of Barcode (Pixel)
property Height: integer read FHeight write FHeight;
property Text: string read FText write SetText;
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;
// 0 - 360 degree
property Angle: double read FAngle write FAngle;
property ShowText: boolean read FShowText write FShowText default False;
property Width: integer read GetWidth;
end;
// procedure Register; // Removed by TZ
implementation
{
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(aOwner: TComponent);
begin
inherited Create(aOwner);
FAngle := 0.0;
FRatio := 2.0;
FModul := 1;
FTyp := bcCodeEAN13;
FCheckSum := False;
FShowText := False;
end;
function TBarcode.GetTypText: string;
const
bcNames: array[bcCode_2_5_interleaved..bcCodeEAN13] of string =
(
('2_5_interleaved'),
('2_5_industrial'),
('2_5_matrix'),
('Code39'),
('Code39 Extended'),
('Code128A'),
('Code128B'),
('Code128C'),
('Code93'),
('Code93 Extended'),
('MSI'),
('PostNet'),
('Codebar'),
('EAN8'),
('EAN13')
);
begin
Result := bcNames[FTyp];
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; out aWidth: integer; out lt: TBarLineType);
begin
case code of
'0':
begin
aWidth := modules[0];
lt := white;
end;
'1':
begin
aWidth := modules[1];
lt := white;
end;
'2':
begin
aWidth := modules[2];
lt := white;
end;
'3':
begin
aWidth := modules[3];
lt := white;
end;
'5':
begin
aWidth := modules[0];
lt := black;
end;
'6':
begin
aWidth := modules[1];
lt := black;
end;
'7':
begin
aWidth := modules[2];
lt := black;
end;
'8':
begin
aWidth := modules[3];
lt := black;
end;
'A':
begin
aWidth := modules[0];
lt := black_half;
end;
'B':
begin
aWidth := modules[1];
lt := black_half;
end;
'C':
begin
aWidth := modules[2];
lt := black_half;
end;
'D':
begin
aWidth := 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;
begin
// calculate the with of the different lines (modules)
MakeModules;
// get the pattern of the barcode
case Typ of
bcCode_2_5_interleaved:
Result := Code_2_5_interleaved;
bcCode_2_5_industrial:
Result := Code_2_5_industrial;
bcCode_2_5_matrix:
Result := Code_2_5_matrix;
bcCode39:
Result := Code_39;
bcCode39Extended:
Result := Code_39Extended;
bcCode128A,
bcCode128B,
bcCode128C:
Result := Code_128;
bcCode93:
Result := Code_93;
bcCode93Extended:
Result := Code_93Extended;
bcCodeMSI:
Result := Code_MSI;
bcCodePostNet:
Result := Code_PostNet;
bcCodeCodabar:
Result := Code_Codabar;
bcCodeEAN8:
Result := Code_EAN8;
bcCodeEAN13:
Result := Code_EAN13;
else
raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]);
end;
//Showmessage(Format('Data <%s>', [Result]));
end;
function TBarcode.GetWidth: integer;
var
Data: string;
i: integer;
w: integer;
lt: TBarLineType;
begin
Result := 0;
// get barcode pattern
Data := MakeData;
for i := 1 to Length(Data) do // examine the pattern string
begin
OneBarProps(Data[i], w, lt);
Inc(Result, w);
end;
end;
procedure TBarcode.SetText(AValue: string);
begin
if FText=AValue then Exit;
FText:=AValue;
FCodeText:=AValue;
end;
////////////////////////////// EAN /////////////////////////////////////////
function getEAN(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]) * 1)
else
sum := sum + (StrToInt(tmp[i]) * 3);
Dec(fak);
end;
if (sum mod 10) = 0 then
Result := tmp + '0'
else
Result := tmp + IntToStr(10 - (sum mod 10));
end;
////////////////////////////// EAN8 /////////////////////////////////////////
// Pattern for Barcode EAN Zeichensatz A
// L1 S1 L2 S2
const
tabelle_EAN_A: array['0'..'9', 1..4] of char =
(
('2', '6', '0', '5'), // 0
('1', '6', '1', '5'), // 1
('1', '5', '1', '6'), // 2
('0', '8', '0', '5'), // 3
('0', '5', '2', '6'), // 4
('0', '6', '2', '5'), // 5
('0', '5', '0', '8'), // 6
('0', '7', '0', '6'), // 7
('0', '6', '0', '7'), // 8
('2', '5', '0', '6') // 9
);
// Pattern for Barcode EAN Zeichensatz C
// S1 L1 S2 L2
const
tabelle_EAN_C: array['0'..'9', 1..4] of char =
(
('7', '1', '5', '0'), // 0
('6', '1', '6', '0'), // 1
('6', '0', '6', '1'), // 2
('5', '3', '5', '0'), // 3
('5', '0', '7', '1'), // 4
('5', '1', '7', '0'), // 5
('5', '0', '5', '3'), // 6
('5', '2', '5', '1'), // 7
('5', '1', '5', '2'), // 8
('7', '0', '5', '1') // 9
);
function TBarcode.Code_EAN8: string;
var
i, j: integer;
begin
FCodeText := CleanEANValue(FText, 8);
Result := '505'; // Startcode
for i := 1 to 4 do
for j := 1 to 4 do
begin
Result := Result + tabelle_EAN_A[FCodeText[i], j];
end;
Result := Result + '05050'; // Trennzeichen
for i := 5 to 8 do
for j := 1 to 4 do
begin
Result := Result + tabelle_EAN_C[FCodeText[i], j];
end;
Result := Result + '505'; // Stopcode
end;
////////////////////////////// EAN13 ///////////////////////////////////////
// Pattern for Barcode EAN Zeichensatz B
// L1 S1 L2 S2
const
tabelle_EAN_B: array['0'..'9', 1..4] of char =
(
('0', '5', '1', '7'), // 0
('0', '6', '1', '6'), // 1
('1', '6', '0', '6'), // 2
('0', '5', '3', '5'), // 3
('1', '7', '0', '5'), // 4
('0', '7', '1', '5'), // 5
('3', '5', '0', '5'), // 6
('1', '5', '2', '5'), // 7
('2', '5', '1', '5'), // 8
('1', '5', '0', '7') // 9
);
// Zuordung der Paraitaetsfolgen für EAN13
const
tabelle_ParityEAN13: array[0..9, 1..6] of char =
(
('A', 'A', 'A', 'A', 'A', 'A'), // 0
('A', 'A', 'B', 'A', 'B', 'B'), // 1
('A', 'A', 'B', 'B', 'A', 'B'), // 2
('A', 'A', 'B', 'B', 'B', 'A'), // 3
('A', 'B', 'A', 'A', 'B', 'B'), // 4
('A', 'B', 'B', 'A', 'A', 'B'), // 5
('A', 'B', 'B', 'B', 'A', 'A'), // 6
('A', 'B', 'A', 'B', 'A', 'B'), // 7
('A', 'B', 'A', 'B', 'B', 'A'), // 8
('A', 'B', 'B', 'A', 'B', 'A') // 9
);
function TBarcode.Code_EAN13: string;
var
i, j, LK: integer;
tmp: string;
begin
FCodeText := CleanEanValue(FText, 13);
LK := StrToInt(FCodeText[1]);
tmp := copy(FCodeText, 2, 12);
Result := '505'; // Startcode
for i := 1 to 6 do
begin
case tabelle_ParityEAN13[LK, i] of
'A':
for j := 1 to 4 do
Result := Result + tabelle_EAN_A[tmp[i], j];
'B':
for j := 1 to 4 do
Result := Result + tabelle_EAN_B[tmp[i], j];
'C':
for j := 1 to 4 do
Result := Result + tabelle_EAN_C[tmp[i], j];
end;
end;
Result := Result + '05050'; // Trennzeichen
for i := 7 to 12 do
for j := 1 to 4 do
begin
Result := Result + tabelle_EAN_C[tmp[i], j];
end;
Result := Result + '505'; // Stopcode
end;
// Pattern for Barcode 2 of 5
const
tabelle_2_5: array['0'..'9', 1..5] of char =
(
('0', '0', '1', '1', '0'), // 0
('1', '0', '0', '0', '1'), // 1
('0', '1', '0', '0', '1'), // 2
('1', '1', '0', '0', '0'), // 3
('0', '0', '1', '0', '1'), // 4
('1', '0', '1', '0', '0'), // 5
('0', '1', '1', '0', '0'), // 6
('0', '0', '0', '1', '1'), // 7
('1', '0', '0', '1', '0'), // 8
('0', '1', '0', '1', '0') // 9
);
function TBarcode.Code_2_5_interleaved: string;
var
i, j: integer;
c: char;
begin
Result := '5050'; // Startcode
for i := 1 to Length(FText) div 2 do
begin
for j := 1 to 5 do
begin
if tabelle_2_5[FText[i * 2 - 1], j] = '1' then
c := '6'
else
c := '5';
Result := Result + c;
if tabelle_2_5[FText[i * 2], j] = '1' then
c := '1'
else
c := '0';
Result := Result + c;
end;
end;
Result := Result + '605'; // Stopcode
end;
function TBarcode.Code_2_5_industrial: string;
var
i, j: integer;
begin
Result := '606050'; // Startcode
for i := 1 to Length(FText) do
begin
for j := 1 to 5 do
begin
if tabelle_2_5[FText[i], j] = '1' then
Result := Result + '60'
else
Result := Result + '50';
end;
end;
Result := Result + '605060'; // Stopcode
end;
function TBarcode.Code_2_5_matrix: string;
var
i, j: integer;
c: char;
begin
Result := '705050'; // Startcode
for i := 1 to Length(FText) do
begin
for j := 1 to 5 do
begin
if tabelle_2_5[FText[i], j] = '1' then
c := '1'
else
c := '0';
// Falls i ungerade ist dann mache Lücke zu Strich
if odd(j) then
c := chr(Ord(c) + 5);
Result := Result + c;
end;
Result := Result + '0'; // Lücke zwischen den Zeichen
end;
Result := Result + '70505'; // Stopcode
end;
function TBarcode.Code_39: string;
type
TCode39 = record
c: char;
Data: array[0..9] of char;
chk: shortint;
end;
const
tabelle_39: array[0..43] of TCode39 = (
(c: '0'; Data: '505160605'; chk: 0),
(c: '1'; Data: '605150506'; chk: 1),
(c: '2'; Data: '506150506'; chk: 2),
(c: '3'; Data: '606150505'; chk: 3),
(c: '4'; Data: '505160506'; chk: 4),
(c: '5'; Data: '605160505'; chk: 5),
(c: '6'; Data: '506160505'; chk: 6),
(c: '7'; Data: '505150606'; chk: 7),
(c: '8'; Data: '605150605'; chk: 8),
(c: '9'; Data: '506150605'; chk: 9),
(c: 'A'; Data: '605051506'; chk: 10),
(c: 'B'; Data: '506051506'; chk: 11),
(c: 'C'; Data: '606051505'; chk: 12),
(c: 'D'; Data: '505061506'; chk: 13),
(c: 'E'; Data: '605061505'; chk: 14),
(c: 'F'; Data: '506061505'; chk: 15),
(c: 'G'; Data: '505051606'; chk: 16),
(c: 'H'; Data: '605051605'; chk: 17),
(c: 'I'; Data: '506051600'; chk: 18),
(c: 'J'; Data: '505061605'; chk: 19),
(c: 'K'; Data: '605050516'; chk: 20),
(c: 'L'; Data: '506050516'; chk: 21),
(c: 'M'; Data: '606050515'; chk: 22),
(c: 'N'; Data: '505060516'; chk: 23),
(c: 'O'; Data: '605060515'; chk: 24),
(c: 'P'; Data: '506060515'; chk: 25),
(c: 'Q'; Data: '505050616'; chk: 26),
(c: 'R'; Data: '605050615'; chk: 27),
(c: 'S'; Data: '506050615'; chk: 28),
(c: 'T'; Data: '505060615'; chk: 29),
(c: 'U'; Data: '615050506'; chk: 30),
(c: 'V'; Data: '516050506'; chk: 31),
(c: 'W'; Data: '616050505'; chk: 32),
(c: 'X'; Data: '515060506'; chk: 33),
(c: 'Y'; Data: '615060505'; chk: 34),
(c: 'Z'; Data: '516060505'; chk: 35),
(c: '-'; Data: '515050606'; chk: 36),
(c: '.'; Data: '615050605'; chk: 37),
(c: ' '; Data: '516050605'; chk: 38),
(c: '*'; Data: '515060605'; chk: 0),
(c: '$'; Data: '515151505'; chk: 39),
(c: '/'; Data: '515150515'; chk: 40),
(c: '+'; Data: '515051515'; chk: 41),
(c: '%'; Data: '505151515'; chk: 42)
);
function FindIdx(z: char): integer;
var
i: integer;
begin
Result := -1;
for i := 0 to High(tabelle_39) do
begin
if z = tabelle_39[i].c then
begin
Result := i;
Break;
end;
end;
end;
var
i, idx: integer;
vChecksum: integer;
begin
vChecksum := 0;
// Startcode
Result := tabelle_39[FindIdx('*')].Data + '0';
for i := 1 to Length(FText) do
begin
idx := FindIdx(FText[i]);
if idx < 0 then
continue;
Result := Result + tabelle_39[idx].Data + '0';
Inc(vChecksum, tabelle_39[idx].chk);
end;
// Calculate Checksum Data
if FCheckSum then
begin
vChecksum := vChecksum mod 43;
for i := 0 to High(tabelle_39) do
if vChecksum = tabelle_39[i].chk then
begin
Result := Result + tabelle_39[i].Data + '0';
exit;
end;
end;
// Stopcode
Result := Result + tabelle_39[FindIdx('*')].Data;
end;
function TBarcode.Code_39Extended: string;
const
code39x: array[0..127] of string[2] =
(
('%U'), ('$A'), ('$B'), ('$C'), ('$D'), ('$E'), ('$F'), ('$G'),
('$H'), ('$I'), ('$J'), ('$K'), ('$L'), ('$M'), ('$N'), ('$O'),
('$P'), ('$Q'), ('$R'), ('$S'), ('$T'), ('$U'), ('$V'), ('$W'),
('$X'), ('$Y'), ('$Z'), ('%A'), ('%B'), ('%C'), ('%D'), ('%E'),
(' '), ('/A'), ('/B'), ('/C'), ('/D'), ('/E'), ('/F'), ('/G'),
('/H'), ('/I'), ('/J'), ('/K'), ('/L'), ('/M'), ('/N'), ('/O'),
('0'), ('1'), ('2'), ('3'), ('4'), ('5'), ('6'), ('7'),
('8'), ('9'), ('/Z'), ('%F'), ('%G'), ('%H'), ('%I'), ('%J'),
('%V'), ('A'), ('B'), ('C'), ('D'), ('E'), ('F'), ('G'),
('H'), ('I'), ('J'), ('K'), ('L'), ('M'), ('N'), ('O'),
('P'), ('Q'), ('R'), ('S'), ('T'), ('U'), ('V'), ('W'),
('X'), ('Y'), ('Z'), ('%K'), ('%L'), ('%M'), ('%N'), ('%O'),
('%W'), ('+A'), ('+B'), ('+C'), ('+D'), ('+E'), ('+F'), ('+G'),
('+H'), ('+I'), ('+J'), ('+K'), ('+L'), ('+M'), ('+N'), ('+O'),
('+P'), ('+Q'), ('+R'), ('+S'), ('+T'), ('+U'), ('+V'), ('+W'),
('+X'), ('+Y'), ('+Z'), ('%P'), ('%Q'), ('%R'), ('%S'), ('%T')
);
var
save: string;
i: integer;
begin
save := FText;
FText := '';
for i := 1 to Length(save) do
begin
if Ord(save[i]) <= 127 then
FText := FText + code39x[Ord(save[i])];
end;
Result := Code_39;
FText := save;
end;
{
Code 128
}
function TBarcode.Code_128: string;
type
TCode128 = record
a, b: char;
c: string[2];
Data: string[6];
end;
const
tabelle_128: array[0..102] of TCode128 = (
(a: ' '; b: ' '; c: '00'; Data: '212222'; ),
(a: '!'; b: '!'; c: '01'; Data: '222122'; ),
(a: '"'; b: '"'; c: '02'; Data: '222221'; ),
(a: '#'; b: '#'; c: '03'; Data: '121223'; ),
(a: '$'; b: '$'; c: '04'; Data: '121322'; ),
(a: '%'; b: '%'; c: '05'; Data: '131222'; ),
(a: '&'; b: '&'; c: '06'; Data: '122213'; ),
(a: ''''; b: ''''; c: '07'; Data: '122312'; ),
(a: '('; b: '('; c: '08'; Data: '132212'; ),
(a: ')'; b: ')'; c: '09'; Data: '221213'; ),
(a: '*'; b: '*'; c: '10'; Data: '221312'; ),
(a: '+'; b: '+'; c: '11'; Data: '231212'; ),
(a: ','; b: ','; c: '12'; Data: '112232'; ),
(a: '-'; b: '-'; c: '13'; Data: '122132'; ),
(a: '.'; b: '.'; c: '14'; Data: '122231'; ),
(a: '/'; b: '/'; c: '15'; Data: '113222'; ),
(a: '0'; b: '0'; c: '16'; Data: '123122'; ),
(a: '1'; b: '1'; c: '17'; Data: '123221'; ),
(a: '2'; b: '2'; c: '18'; Data: '223211'; ),
(a: '3'; b: '3'; c: '19'; Data: '221132'; ),
(a: '4'; b: '4'; c: '20'; Data: '221231'; ),
(a: '5'; b: '5'; c: '21'; Data: '213212'; ),
(a: '6'; b: '6'; c: '22'; Data: '223112'; ),
(a: '7'; b: '7'; c: '23'; Data: '312131'; ),
(a: '8'; b: '8'; c: '24'; Data: '311222'; ),
(a: '9'; b: '9'; c: '25'; Data: '321122'; ),
(a: ':'; b: ':'; c: '26'; Data: '321221'; ),
(a: ';'; b: ';'; c: '27'; Data: '312212'; ),
(a: '<'; b: '<'; c: '28'; Data: '322112'; ),
(a: '='; b: '='; c: '29'; Data: '322211'; ),
(a: '>'; b: '>'; c: '30'; Data: '212123'; ),
(a: '?'; b: '?'; c: '31'; Data: '212321'; ),
(a: '@'; b: '@'; c: '32'; Data: '232121'; ),
(a: 'A'; b: 'A'; c: '33'; Data: '111323'; ),
(a: 'B'; b: 'B'; c: '34'; Data: '131123'; ),
(a: 'C'; b: 'C'; c: '35'; Data: '131321'; ),
(a: 'D'; b: 'D'; c: '36'; Data: '112313'; ),
(a: 'E'; b: 'E'; c: '37'; Data: '132113'; ),
(a: 'F'; b: 'F'; c: '38'; Data: '132311'; ),
(a: 'G'; b: 'G'; c: '39'; Data: '211313'; ),
(a: 'H'; b: 'H'; c: '40'; Data: '231113'; ),
(a: 'I'; b: 'I'; c: '41'; Data: '231311'; ),
(a: 'J'; b: 'J'; c: '42'; Data: '112133'; ),
(a: 'K'; b: 'K'; c: '43'; Data: '112331'; ),
(a: 'L'; b: 'L'; c: '44'; Data: '132131'; ),
(a: 'M'; b: 'M'; c: '45'; Data: '113123'; ),
(a: 'N'; b: 'N'; c: '46'; Data: '113321'; ),
(a: 'O'; b: 'O'; c: '47'; Data: '133121'; ),
(a: 'P'; b: 'P'; c: '48'; Data: '313121'; ),
(a: 'Q'; b: 'Q'; c: '49'; Data: '211331'; ),
(a: 'R'; b: 'R'; c: '50'; Data: '231131'; ),
(a: 'S'; b: 'S'; c: '51'; Data: '213113'; ),
(a: 'T'; b: 'T'; c: '52'; Data: '213311'; ),
(a: 'U'; b: 'U'; c: '53'; Data: '213131'; ),
(a: 'V'; b: 'V'; c: '54'; Data: '311123'; ),
(a: 'W'; b: 'W'; c: '55'; Data: '311321'; ),
(a: 'X'; b: 'X'; c: '56'; Data: '331121'; ),
(a: 'Y'; b: 'Y'; c: '57'; Data: '312113'; ),
(a: 'Z'; b: 'Z'; c: '58'; Data: '312311'; ),
(a: '['; b: '['; c: '59'; Data: '332111'; ),
(a: '\'; b: '\'; c: '60'; Data: '314111'; ),
(a: ']'; b: ']'; c: '61'; Data: '221411'; ),
(a: '^'; b: '^'; c: '62'; Data: '431111'; ),
(a: '_'; b: '_'; c: '63'; Data: '111224'; ),
(a: ' '; b: '`'; c: '64'; Data: '111422'; ),
(a: ' '; b: 'a'; c: '65'; Data: '121124'; ),
(a: ' '; b: 'b'; c: '66'; Data: '121421'; ),
(a: ' '; b: 'c'; c: '67'; Data: '141122'; ),
(a: ' '; b: 'd'; c: '68'; Data: '141221'; ),
(a: ' '; b: 'e'; c: '69'; Data: '112214'; ),
(a: ' '; b: 'f'; c: '70'; Data: '112412'; ),
(a: ' '; b: 'g'; c: '71'; Data: '122114'; ),
(a: ' '; b: 'h'; c: '72'; Data: '122411'; ),
(a: ' '; b: 'i'; c: '73'; Data: '142112'; ),
(a: ' '; b: 'j'; c: '74'; Data: '142211'; ),
(a: ' '; b: 'k'; c: '75'; Data: '241211'; ),
(a: ' '; b: 'l'; c: '76'; Data: '221114'; ),
(a: ' '; b: 'm'; c: '77'; Data: '413111'; ),
(a: ' '; b: 'n'; c: '78'; Data: '241112'; ),
(a: ' '; b: 'o'; c: '79'; Data: '134111'; ),
(a: ' '; b: 'p'; c: '80'; Data: '111242'; ),
(a: ' '; b: 'q'; c: '81'; Data: '121142'; ),
(a: ' '; b: 'r'; c: '82'; Data: '121241'; ),
(a: ' '; b: 's'; c: '83'; Data: '114212'; ),
(a: ' '; b: 't'; c: '84'; Data: '124112'; ),
(a: ' '; b: 'u'; c: '85'; Data: '124211'; ),
(a: ' '; b: 'v'; c: '86'; Data: '411212'; ),
(a: ' '; b: 'w'; c: '87'; Data: '421112'; ),
(a: ' '; b: 'x'; c: '88'; Data: '421211'; ),
(a: ' '; b: 'y'; c: '89'; Data: '212141'; ),
(a: ' '; b: 'z'; c: '90'; Data: '214121'; ),
(a: ' '; b: '{'; c: '91'; Data: '412121'; ),
(a: ' '; b: '|'; c: '92'; Data: '111143'; ),
(a: ' '; b: '}'; c: '93'; Data: '111341'; ),
(a: ' '; b: '~'; c: '94'; Data: '131141'; ),
(a: ' '; b: ' '; c: '95'; Data: '114113'; ),
(a: ' '; b: ' '; c: '96'; Data: '114311'; ),
(a: ' '; b: ' '; c: '97'; Data: '411113'; ),
(a: ' '; b: ' '; c: '98'; Data: '411311'; ),
(a: ' '; b: ' '; c: '99'; Data: '113141'; ),
(a: ' '; b: ' '; c: ' '; Data: '114131'; ),
(a: ' '; b: ' '; c: ' '; Data: '311141'; ),
(a: ' '; b: ' '; c: ' '; Data: '411131'; )
);
StartA = '211412';
StartB = '211214';
StartC = '211232';
Stop = '2331112';
// find Code 128 Codeset A or B
function Find_Code128AB(c: char): integer;
var
i: integer;
v: char;
begin
for i := 0 to High(tabelle_128) do
begin
if FTyp = bcCode128A then
v := tabelle_128[i].a
else
v := tabelle_128[i].b;
if c = v then
begin
Result := i;
exit;
end;
end;
Result := -1;
end;
var
i, idx: integer;
startcode, tmp: string;
vChecksum: integer;
begin
vChecksum := 0; // Added by TZ
case FTyp of
bcCode128A:
begin
vChecksum := 103;
startcode := StartA;
FCodeText := FText;
end;
bcCode128B:
begin
vChecksum := 104;
startcode := StartB;
FCodeText := FText;
end;
bcCode128C:
begin
vChecksum := 105;
startcode := StartC;
// make sure we have an even numeric only string
FCodeText := '';
for i := 1 to Length(FText) do
if not (FText[i] in ['0'..'9']) then
FCodeText := FCodeText + '0'
else
FCodeText := FCodeText + FText[i];
if Odd(Length(FText)) then
FCodeText := '0' + FText;
end;
end;
Result := Convert(startcode); // Startcode
if FTyp = bcCode128C then
begin
tmp := '';
i := 1;
while i<Length(FCodeText) do
begin
tmp := tmp + chr( StrToIntDef(Copy(FCodeText, i, 2), 0) );
inc(i,2);
end;
end else
tmp := FCodeText;
for i := 1 to Length(tmp) do
begin
if FTyp = bcCode128C then
idx := Ord(tmp[i])
else begin
idx := Find_Code128AB(tmp[i]);
if idx < 0 then
idx := Find_Code128AB(' ');
end;
Result := Result + Convert(tabelle_128[idx].Data);
Inc(vChecksum, idx * i);
end;
vChecksum := vChecksum mod 103;
Result := Result + Convert(tabelle_128[vChecksum].Data);
Result := Result + Convert(Stop); // Stopcode
end;
function TBarcode.Code_93: string;
type
TCode93 = record
c: char;
Data: array[0..5] of char;
end;
const
tabelle_93: array[0..46] of TCode93 = (
(c: '0'; Data: '131112'),
(c: '1'; Data: '111213'),
(c: '2'; Data: '111312'),
(c: '3'; Data: '111411'),
(c: '4'; Data: '121113'),
(c: '5'; Data: '121212'),
(c: '6'; Data: '121311'),
(c: '7'; Data: '111114'),
(c: '8'; Data: '131211'),
(c: '9'; Data: '141111'),
(c: 'A'; Data: '211113'),
(c: 'B'; Data: '211212'),
(c: 'C'; Data: '211311'),
(c: 'D'; Data: '221112'),
(c: 'E'; Data: '221211'),
(c: 'F'; Data: '231111'),
(c: 'G'; Data: '112113'),
(c: 'H'; Data: '112212'),
(c: 'I'; Data: '112311'),
(c: 'J'; Data: '122112'),
(c: 'K'; Data: '132111'),
(c: 'L'; Data: '111123'),
(c: 'M'; Data: '111222'),
(c: 'N'; Data: '111321'),
(c: 'O'; Data: '121122'),
(c: 'P'; Data: '131121'),
(c: 'Q'; Data: '212112'),
(c: 'R'; Data: '212211'),
(c: 'S'; Data: '211122'),
(c: 'T'; Data: '211221'),
(c: 'U'; Data: '221121'),
(c: 'V'; Data: '222111'),
(c: 'W'; Data: '112122'),
(c: 'X'; Data: '112221'),
(c: 'Y'; Data: '122121'),
(c: 'Z'; Data: '123111'),
(c: '-'; Data: '121131'),
(c: '.'; Data: '311112'),
(c: ' '; Data: '311211'),
(c: '$'; Data: '321111'),
(c: '/'; Data: '112131'),
(c: '+'; Data: '113121'),
(c: '%'; Data: '211131'),
(c: '['; Data: '121221'), // only used for Extended Code 93
(c: ']'; Data: '312111'), // only used for Extended Code 93
(c: '{'; Data: '311121'), // only used for Extended Code 93
(c: '}'; Data: '122211') // only used for Extended Code 93
);
// find Code 93
function Find_Code93(c: char): integer;
var
i: integer;
begin
for i := 0 to High(tabelle_93) do
begin
if c = tabelle_93[i].c then
begin
Result := i;
exit;
end;
end;
Result := -1;
end;
var
i, idx: integer;
checkC, checkK, // Checksums
weightC, weightK: integer;
begin
Result := Convert('111141'); // Startcode
for i := 1 to Length(FText) do
begin
idx := Find_Code93(FText[i]);
if idx < 0 then
raise Exception.CreateFmt('%s:Code93 bad Data <%s>', [self.ClassName, FText]);
Result := Result + Convert(tabelle_93[idx].Data);
end;
checkC := 0;
checkK := 0;
weightC := 1;
weightK := 2;
for i := Length(FText) downto 1 do
begin
idx := Find_Code93(FText[i]);
Inc(checkC, idx * weightC);
Inc(checkK, idx * weightK);
Inc(weightC);
if weightC > 20 then
weightC := 1;
Inc(weightK);
if weightK > 15 then
weightC := 1;
end;
Inc(checkK, checkC);
checkC := checkC mod 47;
checkK := checkK mod 47;
Result := Result + Convert(tabelle_93[checkC].Data) +
Convert(tabelle_93[checkK].Data);
Result := Result + Convert('1111411'); // Stopcode
end;
function TBarcode.Code_93Extended: string;
const
code93x: array[0..127] of string[2] =
(
(']U'), ('[A'), ('[B'), ('[C'), ('[D'), ('[E'), ('[F'), ('[G'),
('[H'), ('[I'), ('[J'), ('[K'), ('[L'), ('[M'), ('[N'), ('[O'),
('[P'), ('[Q'), ('[R'), ('[S'), ('[T'), ('[U'), ('[V'), ('[W'),
('[X'), ('[Y'), ('[Z'), (']A'), (']B'), (']C'), (']D'), (']E'),
(' '), ('{A'), ('{B'), ('{C'), ('{D'), ('{E'), ('{F'), ('{G'),
('{H'), ('{I'), ('{J'), ('{K'), ('{L'), ('{M'), ('{N'), ('{O'),
('0'), ('1'), ('2'), ('3'), ('4'), ('5'), ('6'), ('7'),
('8'), ('9'), ('{Z'), (']F'), (']G'), (']H'), (']I'), (']J'),
(']V'), ('A'), ('B'), ('C'), ('D'), ('E'), ('F'), ('G'),
('H'), ('I'), ('J'), ('K'), ('L'), ('M'), ('N'), ('O'),
('P'), ('Q'), ('R'), ('S'), ('T'), ('U'), ('V'), ('W'),
('X'), ('Y'), ('Z'), (']K'), (']L'), (']M'), (']N'), (']O'),
(']W'), ('}A'), ('}B'), ('}C'), ('}D'), ('}E'), ('}F'), ('}G'),
('}H'), ('}I'), ('}J'), ('}K'), ('}L'), ('}M'), ('}N'), ('}O'),
('}P'), ('}Q'), ('}R'), ('}S'), ('}T'), ('}U'), ('}V'), ('}W'),
('}X'), ('}Y'), ('}Z'), (']P'), (']Q'), (']R'), (']S'), (']T')
);
var
// save:array[0..254] of char;
// old:string;
save: string;
i: integer;
begin
// CharToOem(PChar(FText), save);
save := FText;
FText := '';
for i := 0 to Length(save) - 1 do
begin
if Ord(save[i]) <= 127 then
FText := FText + code93x[Ord(save[i])];
end;
//Showmessage(Format('Text: <%s>', [FText]));
Result := Code_93;
FText := save;
end;
function TBarcode.Code_MSI: string;
const
tabelle_MSI: array['0'..'9'] of string[8] =
(
('51515151'), // '0'
('51515160'), // '1'
('51516051'), // '2'
('51516060'), // '3'
('51605151'), // '4'
('51605160'), // '5'
('51606051'), // '6'
('51606060'), // '7'
('60515151'), // '8'
('60515160') // '9'
);
var
i: integer;
check_even, check_odd, vChecksum: integer;
begin
Result := '60'; // Startcode
check_even := 0;
check_odd := 0;
for i := 1 to Length(FText) do
begin
if odd(i - 1) then
check_odd := check_odd * 10 + Ord(FText[i])
else
check_even := check_even + Ord(FText[i]);
Result := Result + tabelle_MSI[FText[i]];
end;
vChecksum := quersumme(check_odd * 2) + check_even;
vChecksum := vChecksum mod 10;
if vChecksum > 0 then
vChecksum := 10 - vChecksum;
Result := Result + tabelle_MSI[chr(Ord('0') + vChecksum)];
Result := Result + '515'; // Stopcode
end;
function TBarcode.Code_PostNet: string;
const
tabelle_PostNet: array['0'..'9'] of string[10] =
(
('5151A1A1A1'), // '0'
('A1A1A15151'), // '1'
('A1A151A151'), // '2'
('A1A15151A1'), // '3'
('A151A1A151'), // '4'
('A151A151A1'), // '5'
('A15151A1A1'), // '6'
('51A1A1A151'), // '7'
('51A1A151A1'), // '8'
('51A151A1A1') // '9'
);
var
i: integer;
begin
Result := '51';
for i := 1 to Length(FText) do
begin
Result := Result + tabelle_PostNet[FText[i]];
end;
Result := Result + '5';
end;
function TBarcode.Code_Codabar: string;
type
TCodabar = record
c: char;
Data: array[0..6] of char;
end;
const
tabelle_cb: array[0..19] of TCodabar = (
(c: '1'; Data: '5050615'),
(c: '2'; Data: '5051506'),
(c: '3'; Data: '6150505'),
(c: '4'; Data: '5060515'),
(c: '5'; Data: '6050515'),
(c: '6'; Data: '5150506'),
(c: '7'; Data: '5150605'),
(c: '8'; Data: '5160505'),
(c: '9'; Data: '6051505'),
(c: '0'; Data: '5050516'),
(c: '-'; Data: '5051605'),
(c: '$'; Data: '5061505'),
(c: ':'; Data: '6050606'),
(c: '/'; Data: '6060506'),
(c: '.'; Data: '6060605'),
(c: '+'; Data: '5060606'),
(c: 'A'; Data: '5061515'),
(c: 'B'; Data: '5151506'),
(c: 'C'; Data: '5051516'),
(c: 'D'; Data: '5051615')
);
// find Codabar
function Find_Codabar(c: char): integer;
var
i: integer;
begin
for i := 0 to High(tabelle_cb) do
begin
if c = tabelle_cb[i].c then
begin
Result := i;
exit;
end;
end;
Result := -1;
end;
var
i, idx: integer;
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;
procedure TBarcode.MakeModules;
begin
case Typ of
bcCode_2_5_interleaved,
bcCode_2_5_industrial,
bcCode39,
bcCodeEAN8,
bcCodeEAN13,
bcCode39Extended,
bcCodeCodabar:
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 TBarcode.DoLines(Data: string; Canvas: TCanvas);
var
i: integer;
lt: TBarLineType;
xadd: integer;
w, h: 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 * pi / 180.0;
with Canvas do
begin
Pen.Width := 1;
for i := 1 to Length(Data) do // examine the pattern string
begin
OneBarProps(Data[i], w, lt);
{
case data[i] of
'0': begin w := modules[0]; lt := white; end;
'1': begin w := modules[1]; lt := white; end;
'2': begin w := modules[2]; lt := white; end;
'3': begin w := modules[3]; lt := white; end;
'5': begin w := modules[0]; lt := black; end;
'6': begin w := modules[1]; lt := black; end;
'7': begin w := modules[2]; lt := black; end;
'8': begin w := modules[3]; lt := black; end;
'A': begin w := modules[0]; lt := black_half; end;
'B': begin w := modules[1]; lt := black_half; end;
'C': begin w := modules[2]; lt := black_half; end;
'D': begin w := modules[3]; lt := black_half; end;
else
begin
// something went wrong
// mistyped pattern table
raise Exception.CreateFmt('%s: internal Error', [self.ClassName]);
end;
end;
}
if (lt = black) or (lt = black_half) then
begin
Pen.Color := clBlack;
end
else
begin
Pen.Color := clWhite;
end;
Brush.Color := Pen.Color;
if lt = black_half then
H := FHeight * 2 div 5
else
H := FHeight;
a.x := xadd;
a.y := 0;
b.x := xadd;
b.y := H;
// c.x := xadd+width;
c.x := xadd + W - 1; // 23.04.1999 Line was 1 Pixel too wide
c.y := H;
// d.x := xadd+width;
d.x := xadd + W - 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 + w;
end;
end;
end;
procedure TBarcode.DrawBarcode(Canvas: TCanvas);
var
Data: string;
SaveFont: TFont;
SavePen: TPen;
SaveBrush: TBrush;
begin
Savefont := TFont.Create;
SavePen := TPen.Create;
SaveBrush := TBrush.Create;
// get barcode pattern
Data := MakeData;
try
// store Canvas properties
Savefont.Assign(Canvas.Font);
SavePen.Assign(Canvas.Pen);
SaveBrush.Assign(Canvas.Brush);
DoLines(Data, Canvas); // draw the barcode
if FShowText then
DrawText(Canvas); // show readable Text
// restore old Canvas properties
Canvas.Font.Assign(savefont);
Canvas.Pen.Assign(SavePen);
Canvas.Brush.Assign(SaveBrush);
finally
Savefont.Free;
SavePen.Free;
SaveBrush.Free;
end;
end;
{
draw contents and type/name of barcode
as human readable text at the left
upper edge of the barcode.
main use for this procedure is testing.
note: this procedure changes Pen and Brush
of the current canvas.
}
procedure TBarcode.DrawText(Canvas: TCanvas);
begin
with Canvas do
begin
Font.Size := 4;
// the fixed font size is a problem, if you
// use very large or small barcodes
Pen.Color := clBlack;
Brush.Color := clWhite;
TextOut(FLeft, FTop, FText); // contents of Barcode
TextOut(FLeft, FTop + 14, GetTypText); // type/name of barcode
end;
end;
// this function returns true for those symbols that correct them selves
// in case invalid data is fed. For example feeding ABCD to 128C numeric
// only symbol, the generated barcode will be for 0000
function TBarcode.BarcodeTypeChecked(AType: TBarcodeType): boolean;
begin
result := aType in [ bcCode128A, bcCode128B, bcCode128C, bcCodeEAN8,
bcCodeEAN13 ];
end;
function TBarcode.CleanEANValue(const AValue:string; const ASize: Byte): string;
var
tmp: string;
n,i: Integer;
begin
tmp := AValue;
n := Length(tmp);
// check if there is any strange char in string
for i:=1 to n do
if not (tmp[i] in ['0'..'9']) then
tmp[i] := '0';
// enforce a ASize char string by adding a 0
// verifier digit if necesary or calc it if
// checksum was specified
if n<ASize then begin
tmp := stringofchar('0', ASize-n-1) + tmp + '0';
// TODO: if not FCheckSum was specified
// resulting barcode might be invalid
// as a '0' checksum digit was forced.
end;
if FCheckSum then
Result := getEAN(copy(tmp, 1, ASize-1) + '0')
else
Result := copy(tmp, 1, ASize);
end;
end.
Reference in New Issue View Git Blame Copy Permalink