unit BarCode;{ Barcode Component Version 1.20 (13.10.2000) Copyright 1998-2000 Andreas Schmidt and friendsfor 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: [email protected] or [email protected] 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 and Samuel J. Comstock.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 ([email protected]) 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)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 conflictsKnown Bugs --------- - Top and Left properties must be set at runtime.}interfaceuses WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Printers;type TfrBarcodeType = ( 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 ); TfrBarLineType = (white, black, black_half); {for internal use only} { black_half means a black line with 2/5 height (used for PostNet) } TfrCheckSumMethod = ( csmNone, csmModulo10 ); TfrBarcode = class(TComponent) private { Private-Deklarationen } FHeight : integer; FText : string; FTop : integer; FLeft : integer; FModul : integer; FRatio : double; FTyp : TfrBarcodeType; FCheckSum:boolean; FAngle : double; FColor : TColor; FColorBar:TColor; FCheckSumMethod : TfrCheckSumMethod; FOnChange : TNotifyEvent; iDX, iDY: integer; modules:array[0..3] of shortint; procedure OneBarProps(code:char; var Width:integer; var lt:TfrBarLineType); 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; 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: TfrBarcodeType); procedure SetAngle(const Value: Double); procedure SetText(const Value: string); 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; protected { Protected-Deklarationen } function MakeData : string; procedure DoChange; virtual; public { Public-Deklarationen } constructor Create(Owner:TComponent); override; procedure Assign(Source: TPersistent);override; procedure DrawBarcode(Canvas:TCanvas); property CanvasHeight :Integer read GetCanvasHeight; property CanvasWidth :Integer read GetCanvasWidth; procedure PrintBarCode(Canvas:TCanvas; DX, DY: integer); procedure ControlBarCode(Canvas:TCanvas); 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 : TfrBarcodeType read FTyp write SetTyp default bcCode_2_5_interleaved; { build CheckSum ? } property Checksum:boolean read FCheckSum write SetCheckSum default FALSE; property CheckSumMethod:TfrCheckSumMethod read FCheckSumMethod write FCheckSumMethod default csmModulo10; { 0 - 360 degree } property Angle :double read FAngle write SetAngle; 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; 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) );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 TfrBarcode.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 TfrBarcode.Assign(Source: TPersistent); var BSource : TfrBarcode; begin if Source is TfrBarcode then begin BSource := TfrBarcode(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; FOnChange := BSource.FOnChange; end; end;{ set Modul Width } procedure TfrBarcode.SetModul(v:integer); begin if (v >= 1) and (v < 50) then begin FModul := v; DoChange; 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 TfrBarcode.OneBarProps(code:char; var Width:integer; var lt:TfrBarLineType); 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 TfrBarcode.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; {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, bcCodeEAN128A, bcCodeEAN128B, bcCodeEAN128C: 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; bcCodeUPC_A: Result := Code_UPC_A; bcCodeUPC_E0: Result := Code_UPC_E0; bcCodeUPC_E1: Result := Code_UPC_E1; bcCodeUPC_Supp2: Result := Code_Supp2; bcCodeUPC_Supp5: Result := Code_Supp5; else raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]); end;{ Showmessage(Format('Data <%s>', [Result])); } end;function TfrBarcode.GetWidth:integer; var data : string; i : integer; w : integer; lt : TfrBarLineType; 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 TfrBarcode.SetWidth(Value :integer); var data : string; i : integer; w, wtotal : integer; lt : TfrBarLineType; begin wtotal := 0; {get barcode pattern} data := MakeData; for i:=1 to Length(data) do {examine the pattern string} begin OneBarProps(data[i], w, lt); Inc(wtotal, w); end; { wtotal: current width of barcode Value : new width of barcode } if wtotal > 0 then { don't divide by 0 ! } SetModul((FModul * Value) div wtotal); end;function TfrBarcode.DoCheckSumming(const data : string):string; begin case FCheckSumMethod of csmNone: Result := data; csmModulo10: Result := CheckSumModulo10(data); end; end;
{Pattern for Barcode EAN Charset A} {L1 S1 L2 S2} const tabelle_EAN_A:array['0'..'9'] of string = ( ('2605'), { 0 } ('1615'), { 1 } ('1516'), { 2 } ('0805'), { 3 } ('0526'), { 4 } ('0625'), { 5 } ('0508'), { 6 } ('0706'), { 7 } ('0607'), { 8 } ('2506') { 9 } );{Pattern for Barcode EAN Charset C} {S1 L1 S2 L2} const tabelle_EAN_C:array['0'..'9'] of string = ( ('7150' ), { 0 } ('6160' ), { 1 } ('6061' ), { 2 } ('5350' ), { 3 } ('5071' ), { 4 } ('5170' ), { 5 } ('5053' ), { 6 } ('5251' ), { 7 } ('5152' ), { 8 } ('7051' ) { 9 } ); function TfrBarcode.Code_EAN8:string; var i : integer; tmp : String; begin if FCheckSum then begin tmp := SetLen(7); tmp := DoCheckSumming(copy(tmp,length(tmp)-6,7)); end else tmp := SetLen(8); Assert(Length(tmp)=8, 'Invalid Text len (EAN8)'); result := '505'; {Startcode} for i:=1 to 4 do result := result + tabelle_EAN_A[tmp[i]] ; result := result + '05050'; {Center Guard Pattern} for i:=5 to 8 do result := result + tabelle_EAN_C[tmp[i]] ; result := result + '505'; {Stopcode} end;{////////////////////////////// EAN13 ///////////////////////////////////////}{Pattern for Barcode EAN Zeichensatz B} {L1 S1 L2 S2} const tabelle_EAN_B:array['0'..'9'] of string = ( ('0517'), { 0 } ('0616'), { 1 } ('1606'), { 2 } ('0535'), { 3 } ('1705'), { 4 } ('0715'), { 5 } ('3505'), { 6 } ('1525'), { 7 } ('2515'), { 8 } ('1507') { 9 } );{Zuordung der Paraitaetsfolgen f黵 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 TfrBarcode.Code_EAN13:string; var i, LK: integer; tmp : String; begin if FCheckSum then begin tmp := SetLen(12); tmp := DoCheckSumming(tmp); end else tmp := SetLen(13); Assert(Length(tmp) = 13, 'Invalid Text len (EAN13)'); FText := tmp; LK := StrToInt(tmp[1]); tmp := copy(tmp,2,12); result := '505'; {Startcode} for i:=1 to 6 do begin case tabelle_ParityEAN13[LK,i] of 'A' : result := result + tabelle_EAN_A[tmp[i]]; 'B' : result := result + tabelle_EAN_B[tmp[i]] ; 'C' : result := result + tabelle_EAN_C[tmp[i]] ; end; end; result := result + '05050'; {Center Guard Pattern} for i:=7 to 12 do result := result + tabelle_EAN_C[tmp[i]] ; 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 TfrBarcode.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 TfrBarcode.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 TfrBarcode.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點ke zu Strich} if odd(j) then c := chr(ord(c)+5); result := result + c; end; result := result + '0'; {L點ke zwischen den Zeichen} end; result := result + '70505'; {Stopcode} end; function TfrBarcode.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:'506051605'; 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 for i:=0 to High(tabelle_39) do begin if z = tabelle_39[i].c then begin result := i; exit; end; end; result := -1; end;var i, idx : integer; checksum:integer;begin checksum := 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(checksum, tabelle_39[idx].chk); end; {Calculate Checksum Data} if FCheckSum then begin checksum := checksum mod 43; for i:=0 to High(tabelle_39) do if checksum = tabelle_39[i].chk then begin result := result + tabelle_39[i].data + '0'; break; end; end; {Stopcode} result := result + tabelle_39[FindIdx('*')].data; end;function TfrBarcode.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;
Barcode Component
Version 1.20 (13.10.2000)
Copyright 1998-2000 Andreas Schmidt and friendsfor 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:
[email protected] or [email protected] 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 and Samuel J. Comstock.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 ([email protected])
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)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 conflictsKnown Bugs
---------
- Top and Left properties must be set at runtime.}interfaceuses
WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Printers;type
TfrBarcodeType =
(
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
);
TfrBarLineType = (white, black, black_half); {for internal use only}
{ black_half means a black line with 2/5 height (used for PostNet) }
TfrCheckSumMethod =
(
csmNone,
csmModulo10
);
TfrBarcode = class(TComponent)
private
{ Private-Deklarationen }
FHeight : integer;
FText : string;
FTop : integer;
FLeft : integer;
FModul : integer;
FRatio : double;
FTyp : TfrBarcodeType;
FCheckSum:boolean;
FAngle : double;
FColor : TColor;
FColorBar:TColor;
FCheckSumMethod : TfrCheckSumMethod;
FOnChange : TNotifyEvent;
iDX, iDY: integer; modules:array[0..3] of shortint; procedure OneBarProps(code:char; var Width:integer; var lt:TfrBarLineType); 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; 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: TfrBarcodeType);
procedure SetAngle(const Value: Double);
procedure SetText(const Value: string);
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; protected
{ Protected-Deklarationen }
function MakeData : string;
procedure DoChange; virtual; public
{ Public-Deklarationen }
constructor Create(Owner:TComponent); override;
procedure Assign(Source: TPersistent);override; procedure DrawBarcode(Canvas:TCanvas);
property CanvasHeight :Integer read GetCanvasHeight;
property CanvasWidth :Integer read GetCanvasWidth;
procedure PrintBarCode(Canvas:TCanvas; DX, DY: integer);
procedure ControlBarCode(Canvas:TCanvas);
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 : TfrBarcodeType read FTyp write SetTyp default bcCode_2_5_interleaved;
{ build CheckSum ? }
property Checksum:boolean read FCheckSum write SetCheckSum default FALSE;
property CheckSumMethod:TfrCheckSumMethod read FCheckSumMethod write FCheckSumMethod default csmModulo10; { 0 - 360 degree }
property Angle :double read FAngle write SetAngle; 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;
TBCdata = record
Name:string; { Name of Barcode }
num :Boolean; { numeric data only }
end;
(
(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)
);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 TfrBarcode.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 TfrBarcode.Assign(Source: TPersistent);
var
BSource : TfrBarcode;
begin
if Source is TfrBarcode then
begin
BSource := TfrBarcode(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;
FOnChange := BSource.FOnChange;
end;
end;{ set Modul Width }
procedure TfrBarcode.SetModul(v:integer);
begin
if (v >= 1) and (v < 50) then
begin
FModul := v;
DoChange;
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 TfrBarcode.OneBarProps(code:char; var Width:integer; var lt:TfrBarLineType);
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 TfrBarcode.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;
{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,
bcCodeEAN128A,
bcCodeEAN128B,
bcCodeEAN128C: 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;
bcCodeUPC_A: Result := Code_UPC_A;
bcCodeUPC_E0: Result := Code_UPC_E0;
bcCodeUPC_E1: Result := Code_UPC_E1;
bcCodeUPC_Supp2: Result := Code_Supp2;
bcCodeUPC_Supp5: Result := Code_Supp5;
else
raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]);
end;{
Showmessage(Format('Data <%s>', [Result]));
}
end;function TfrBarcode.GetWidth:integer;
var
data : string;
i : integer;
w : integer;
lt : TfrBarLineType;
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 TfrBarcode.SetWidth(Value :integer);
var
data : string;
i : integer;
w, wtotal : integer;
lt : TfrBarLineType;
begin
wtotal := 0; {get barcode pattern}
data := MakeData; for i:=1 to Length(data) do {examine the pattern string}
begin
OneBarProps(data[i], w, lt);
Inc(wtotal, w);
end;
{
wtotal: current width of barcode
Value : new width of barcode } if wtotal > 0 then { don't divide by 0 ! }
SetModul((FModul * Value) div wtotal);
end;function TfrBarcode.DoCheckSumming(const data : string):string;
begin
case FCheckSumMethod of csmNone:
Result := data;
csmModulo10:
Result := CheckSumModulo10(data); end;
end;
{L1 S1 L2 S2}
const tabelle_EAN_A:array['0'..'9'] of string =
(
('2605'), { 0 }
('1615'), { 1 }
('1516'), { 2 }
('0805'), { 3 }
('0526'), { 4 }
('0625'), { 5 }
('0508'), { 6 }
('0706'), { 7 }
('0607'), { 8 }
('2506') { 9 }
);{Pattern for Barcode EAN Charset C}
{S1 L1 S2 L2}
const tabelle_EAN_C:array['0'..'9'] of string =
(
('7150' ), { 0 }
('6160' ), { 1 }
('6061' ), { 2 }
('5350' ), { 3 }
('5071' ), { 4 }
('5170' ), { 5 }
('5053' ), { 6 }
('5251' ), { 7 }
('5152' ), { 8 }
('7051' ) { 9 }
);
function TfrBarcode.Code_EAN8:string;
var
i : integer;
tmp : String;
begin
if FCheckSum then
begin
tmp := SetLen(7);
tmp := DoCheckSumming(copy(tmp,length(tmp)-6,7));
end
else
tmp := SetLen(8); Assert(Length(tmp)=8, 'Invalid Text len (EAN8)'); result := '505'; {Startcode} for i:=1 to 4 do
result := result + tabelle_EAN_A[tmp[i]] ; result := result + '05050'; {Center Guard Pattern} for i:=5 to 8 do
result := result + tabelle_EAN_C[tmp[i]] ; result := result + '505'; {Stopcode}
end;{////////////////////////////// EAN13 ///////////////////////////////////////}{Pattern for Barcode EAN Zeichensatz B}
{L1 S1 L2 S2}
const tabelle_EAN_B:array['0'..'9'] of string =
(
('0517'), { 0 }
('0616'), { 1 }
('1606'), { 2 }
('0535'), { 3 }
('1705'), { 4 }
('0715'), { 5 }
('3505'), { 6 }
('1525'), { 7 }
('2515'), { 8 }
('1507') { 9 }
);{Zuordung der Paraitaetsfolgen f黵 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 TfrBarcode.Code_EAN13:string;
var
i, LK: integer;
tmp : String;
begin
if FCheckSum then
begin
tmp := SetLen(12);
tmp := DoCheckSumming(tmp);
end
else
tmp := SetLen(13); Assert(Length(tmp) = 13, 'Invalid Text len (EAN13)');
FText := tmp; LK := StrToInt(tmp[1]);
tmp := copy(tmp,2,12); result := '505'; {Startcode} for i:=1 to 6 do
begin
case tabelle_ParityEAN13[LK,i] of
'A' : result := result + tabelle_EAN_A[tmp[i]];
'B' : result := result + tabelle_EAN_B[tmp[i]] ;
'C' : result := result + tabelle_EAN_C[tmp[i]] ;
end;
end; result := result + '05050'; {Center Guard Pattern} for i:=7 to 12 do
result := result + tabelle_EAN_C[tmp[i]] ; 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 TfrBarcode.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 TfrBarcode.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 TfrBarcode.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點ke zu Strich}
if odd(j) then
c := chr(ord(c)+5);
result := result + c;
end;
result := result + '0'; {L點ke zwischen den Zeichen}
end; result := result + '70505'; {Stopcode}
end;
function TfrBarcode.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:'506051605'; 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
for i:=0 to High(tabelle_39) do
begin
if z = tabelle_39[i].c then
begin
result := i;
exit;
end;
end;
result := -1;
end;var
i, idx : integer;
checksum:integer;begin
checksum := 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(checksum, tabelle_39[idx].chk);
end; {Calculate Checksum Data}
if FCheckSum then
begin
checksum := checksum mod 43;
for i:=0 to High(tabelle_39) do
if checksum = tabelle_39[i].chk then
begin
result := result + tabelle_39[i].data + '0';
break;
end;
end; {Stopcode}
result := result + tabelle_39[FindIdx('*')].data;
end;function TfrBarcode.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;