home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kolekce / d6 / FRCLX.ZIP / SOURCE / frBarcod.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-06  |  52KB  |  2,064 lines
  1. unit frBarcod;
  2.  
  3. {
  4. Barcode Component
  5. Version 1.20 (13.10.2000)
  6. Copyright 1998-2000 Andreas Schmidt and friends
  7.  
  8. for use with Delphi 1/2/3/4/5
  9. Delphi 1 not tested; better use Delphi 2 (or higher)
  10.  
  11. Freeware
  12. Feel free to distribute the component as
  13. long as all files are unmodified and kept together.
  14.  
  15. I'am not responsible for wrong barcodes.
  16.  
  17. bug-reports, enhancements:
  18. mailto:shmia@bizerba.de or a_j_schmidt@rocketmail.com
  19.  
  20. please tell me wich version you are using, when mailing me.
  21.  
  22.  
  23. get latest version from
  24. http://members.tripod.de/AJSchmidt/index.html
  25.  
  26.  
  27. many thanx and geetings to
  28. Nikolay Simeonov, Wolfgang Koranda, Norbert Waas,
  29. Richard Hugues, Olivier Guilbaud, Berend Tober, Jan Tungli,
  30. Mauro Lemes, Norbert Kostka, Frank De Prins, Shane O'Dea,
  31. Daniele Teti, Ignacio Trivino and Samuel J. Comstock.
  32.  
  33. i use tabs:  1 tab = 3 spaces
  34.  
  35.  
  36. History:
  37. ----------------------------------------------------------------------
  38. Version 1.0:
  39. - initial release
  40. Version 1.1:
  41. - more comments
  42. - changed function Code_93Extended (now correct ?)
  43. Version 1.2:
  44. - Bugs (found by Nikolay Simeonov) removed
  45. Version 1.3:
  46. - EAN8/EAN13 added by Wolfgang Koranda (wkoranda@csi.com)
  47. Version 1.4:
  48. - Bug (found by Norbert Waas) removed
  49.   Component must save the Canvas-properties Font,Pen and Brush
  50. Version 1.5:
  51. - Bug (found by Richard Hugues) removed
  52.   Last line of barcode was 1 Pixel too wide
  53. Version 1.6:
  54. - new read-only property 'Width'
  55. Version 1.7
  56. - check for numeric barcode types
  57. - compatible with Delphi 1 (i hope)
  58. Version 1.8
  59. - add Color and ColorBar properties
  60. Version 1.9
  61. - Code 128 C added by Jan Tungli
  62. Version 1.10
  63. - Bug in Code 39 Character I removed
  64. Version 1.11 (06.07.1999)
  65. - additional Code Types
  66.   CodeUPC_A,
  67.   CodeUPC_E0,
  68.   CodeUPC_E1,
  69.   CodeUPC_Supp2,
  70.   CodeUPC_Supp5
  71.   by Jan Tungli
  72. Version 1.12 (13.07.1999)
  73. - improved ShowText property by Mauro Lemes
  74.   you must change your applications due changed interface of TBarcode.
  75. Version 1.13 (23.07.1999)
  76. - additional Code Types
  77.   CodeEAN128A,
  78.   CodeEAN128B,
  79.   CodeEAN128C
  80.   (support by Norbert Kostka)
  81. - new property 'CheckSumMethod'
  82. Version 1.14 (29.07.1999)
  83. - checksum for EAN128 by Norbert Kostka
  84. - bug fix for EAN128C
  85. Version 1.15 (23.09.1999)
  86. - bug fix for Code 39 with checksum by Frank De Prins
  87. Version 1.16 (10.11.1999)
  88. - width property is now writable (suggestion by Shane O'Dea)
  89. Version 1.17 (27.06.2000)
  90. - new OnChange property
  91. - renamed TBarcode to TAsBarcode to avoid name conflicts
  92. Version 1.18 (25.08.2000)
  93. - some speed improvements (Code 93 and Code 128)
  94. Version 1.19 (27.09.2000)
  95.   (thanks to Samuel J. Comstock)
  96. - origin of the barcode (left upper edge) is moved so that
  97.   the barcode stays always on the canvas
  98. - new (read only) properties 'CanvasWidth' and 'CanvasHeight' gives you
  99.   the size of the resulting image.
  100. - a wrapper class for Quick Reports is now available.
  101. Version 1.20 (13.09.2000)
  102. - Assign procedure added
  103. - support for scaling barcode to Printer (see Demo)
  104.  
  105. Todo (missing features)
  106. -----------------------
  107. - I'am working on PDF417 barcode (has anybody some technical information about PDF417
  108.   or a PDF417 reader ?)
  109. - more CheckSum Methods
  110. - user defined barcodes
  111. - checksum event (fired when the checksum is calculated)
  112. - rename the unit name (from 'barcode' to 'fbarcode') to avoid name conflicts
  113.  
  114.  
  115.  
  116.  
  117.  
  118. Known Bugs
  119. ---------
  120. - Top and Left properties must be set at runtime.
  121.  
  122. }
  123.  
  124.  
  125.  
  126. interface
  127.  
  128. uses
  129.   SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs;
  130.  
  131. type
  132.   TfrBarcodeType =
  133.   (
  134.   bcCode_2_5_interleaved,
  135.   bcCode_2_5_industrial,
  136.   bcCode_2_5_matrix,
  137.   bcCode39,
  138.   bcCode39Extended,
  139.   bcCode128A,
  140.   bcCode128B,
  141.   bcCode128C,
  142.   bcCode93,
  143.   bcCode93Extended,
  144.   bcCodeMSI,
  145.   bcCodePostNet,
  146.   bcCodeCodabar,
  147.   bcCodeEAN8,
  148.   bcCodeEAN13,
  149.   bcCodeUPC_A,
  150.   bcCodeUPC_E0,
  151.   bcCodeUPC_E1,
  152.   bcCodeUPC_Supp2,    { UPC 2 digit supplemental }
  153.   bcCodeUPC_Supp5,    { UPC 5 digit supplemental }
  154.   bcCodeEAN128A,
  155.   bcCodeEAN128B,
  156.   bcCodeEAN128C
  157.   );
  158.  
  159.  
  160.   TfrBarLineType = (white, black, black_half);  {for internal use only}
  161.   { black_half means a black line with 2/5 height (used for PostNet) }
  162.  
  163.  
  164.   TfrCheckSumMethod =
  165.   (
  166.   csmNone,
  167.   csmModulo10
  168.   );
  169.  
  170.  
  171.   TfrBarcode = class(TComponent)
  172.   private
  173.     { Private-Deklarationen }
  174.     FHeight : integer;
  175.     FText  : string;
  176.     FTop    : integer;
  177.     FLeft   : integer;
  178.     FModul  : integer;
  179.     FRatio  : double;
  180.     FTyp    : TfrBarcodeType;
  181.     FCheckSum:boolean;
  182.     FAngle  : double;
  183.     FColor  : TColor;
  184.     FColorBar:TColor;
  185.     FCheckSumMethod : TfrCheckSumMethod;
  186.       FOnChange : TNotifyEvent;
  187.  
  188.  
  189.     modules:array[0..3] of shortint;
  190.  
  191.  
  192.     procedure OneBarProps(code:char; var Width:integer; var lt:TfrBarLineType);
  193.  
  194.     procedure DoLines(data:string; Canvas:TCanvas);
  195.  
  196.     function SetLen(pI:byte):string;
  197.  
  198.     function Code_2_5_interleaved:string;
  199.     function Code_2_5_industrial:string;
  200.     function Code_2_5_matrix:string;
  201.     function Code_39:string;
  202.     function Code_39Extended:string;
  203.     function Code_128:string;
  204.     function Code_93:string;
  205.     function Code_93Extended:string;
  206.     function Code_MSI:string;
  207.     function Code_PostNet:string;
  208.     function Code_Codabar:string;
  209.     function Code_EAN8:string;
  210.     function Code_EAN13:string;
  211.     function Code_UPC_A:string;
  212.     function Code_UPC_E0:string;
  213.     function Code_UPC_E1:string;
  214.     function Code_Supp5:string;
  215.     function Code_Supp2:string;
  216.  
  217.     procedure MakeModules;
  218.  
  219.     procedure SetModul(v:integer);
  220.  
  221.     function GetWidth : integer;
  222.     procedure SetWidth(Value :integer);
  223.  
  224.     function DoCheckSumming(const data : string):string;
  225.       procedure SetRatio(const Value: Double);
  226.       procedure SetTyp(const Value: TfrBarcodeType);
  227.       procedure SetAngle(const Value: Double);
  228.       procedure SetText(const Value: string);
  229.       procedure SetTop(const Value: Integer);
  230.       procedure SetLeft(const Value: Integer);
  231.       procedure SetCheckSum(const Value: Boolean);
  232.     procedure SetHeight(const Value: integer);
  233.     function GetCanvasHeight: Integer;
  234.     function GetCanvasWidth: Integer;
  235.  
  236.   protected
  237.     { Protected-Deklarationen }
  238.     function MakeData : string;
  239.       procedure DoChange; virtual;
  240.  
  241.   public
  242.     { Public-Deklarationen }
  243.     constructor Create(Owner:TComponent); override;
  244.     procedure Assign(Source: TPersistent);override;
  245.  
  246.     procedure DrawBarcode(Canvas:TCanvas);
  247.     property CanvasHeight :Integer read GetCanvasHeight;
  248.     property CanvasWidth :Integer read GetCanvasWidth;
  249.   published
  250.     { Published-Deklarationen }
  251.    { Height of Barcode (Pixel)}
  252.     property Height : integer read FHeight write SetHeight;
  253.     property Text   : string read FText write SetText;
  254.     property Top    : Integer read FTop write SetTop;
  255.     property Left   : Integer read FLeft write SetLeft;
  256.    { Width of the smallest line in a Barcode }
  257.     property Modul  : integer read FModul  write SetModul;
  258.     property Ratio  : Double read FRatio write SetRatio;
  259.     property Typ    : TfrBarcodeType read FTyp write SetTyp default bcCode_2_5_interleaved;
  260.    { build CheckSum ? }
  261.     property Checksum:boolean read FCheckSum write SetCheckSum default FALSE;
  262.     property CheckSumMethod:TfrCheckSumMethod read FCheckSumMethod write FCheckSumMethod default csmModulo10;
  263.  
  264.    { 0 - 360 degree }
  265.     property Angle  :double read FAngle write SetAngle;
  266.  
  267.     property Width : integer read GetWidth write SetWidth stored False;
  268.     property Color:TColor read FColor write FColor default clWhite;
  269.     property ColorBar:TColor read FColorBar write FColorBar default clBlack;
  270.       property OnChange:TNotifyEvent read FOnChange write FOnChange;
  271.   end;
  272.  
  273.  
  274.   TBCdata = record
  275.    Name:string;        { Name of Barcode }
  276.    num :Boolean;       { numeric data only }
  277.   end;
  278.  
  279. const BCdata:array[bcCode_2_5_interleaved..bcCodeEAN128C] of TBCdata =
  280.   (
  281.     (Name:'2_5_interleaved'; num:True),
  282.     (Name:'2_5_industrial';  num:True),
  283.     (Name:'2_5_matrix';      num:True),
  284.     (Name:'Code39';          num:False),
  285.     (Name:'Code39 Extended'; num:False),
  286.     (Name:'Code128A';        num:False),
  287.     (Name:'Code128B';        num:False),
  288.     (Name:'Code128C';        num:True),
  289.     (Name:'Code93';          num:False),
  290.     (Name:'Code93 Extended'; num:False),
  291.     (Name:'MSI';             num:True),
  292.     (Name:'PostNet';         num:True),
  293.     (Name:'Codebar';         num:False),
  294.     (Name:'EAN8';            num:True),
  295.     (Name:'EAN13';           num:True),
  296.     (Name:'UPC_A';           num:True),
  297.     (Name:'UPC_E0';          num:True),
  298.     (Name:'UPC_E1';          num:True),
  299.     (Name:'UPC Supp2';       num:True),
  300.     (Name:'UPC Supp5';       num:True),
  301.     (Name:'EAN128A';         num:False),
  302.     (Name:'EAN128B';         num:False),
  303.     (Name:'EAN128C';         num:True)
  304.   );
  305.  
  306.  
  307. implementation
  308.  
  309.  
  310. function CheckSumModulo10(const data:string):string;
  311.         var i,fak,sum : Integer;
  312. begin
  313.         sum := 0;
  314.         fak := Length(data);
  315.         for i:=1 to Length(data) do
  316.         begin
  317.                 if (fak mod 2) = 0 then
  318.                         sum := sum + (StrToInt(data[i])*1)
  319.                 else
  320.                         sum := sum + (StrToInt(data[i])*3);
  321.                 dec(fak);
  322.         end;
  323.         if (sum mod 10) = 0 then
  324.                 result := data+'0'
  325.         else
  326.                 result := data+IntToStr(10-(sum mod 10));
  327. end;
  328.  
  329. procedure Assert(Cond: Boolean; Text: String);
  330. begin
  331.   if not Cond then
  332.     raise Exception.Create(Text);
  333. end;
  334.  
  335. {
  336.   converts a string from '321' to the internal representation '715'
  337.   i need this function because some pattern tables have a different
  338.   format :
  339.  
  340.   '00111'
  341.   converts to '05161'
  342. }
  343. function Convert(const s:string):string;
  344. var
  345.   i, v : integer;
  346. begin
  347.   Result := s;  { same Length as Input - string }
  348.   for i:=1 to Length(s) do
  349.   begin
  350.     v := ord(s[i]) - 1;
  351.  
  352.     if odd(i) then
  353.       Inc(v, 5);
  354.     Result[i] := Chr(v);
  355.   end;
  356. end;
  357.  
  358. (*
  359.  * Berechne die Quersumme aus einer Zahl x
  360.  * z.B.: Quersumme von 1234 ist 10
  361.  *)
  362. function quersumme(x:integer):integer;
  363. var
  364.   sum:integer;
  365. begin
  366.   sum := 0;
  367.  
  368.   while x > 0 do
  369.   begin
  370.     sum := sum + (x mod 10);
  371.     x := x div 10;
  372.   end;
  373.   result := sum;
  374. end;
  375.  
  376.  
  377. {
  378.   Rotate a Point by Angle 'alpha'
  379. }
  380. function Rotate2D(p:TPoint; alpha:double): TPoint;
  381. var
  382.   sinus, cosinus : Extended;
  383. begin
  384.   sinus   := sin(alpha);
  385.   cosinus := cos(alpha);
  386.   result.x := Round(p.x*cosinus + p.y*sinus);
  387.   result.y := Round(-p.x*sinus + p.y*cosinus);
  388. end;
  389.  
  390. {
  391.   Move Point "a" by Vector "b"
  392. }
  393. function Translate2D(a, b:TPoint): TPoint;
  394. begin
  395.   result.x := a.x + b.x;
  396.   result.y := a.y + b.y;
  397. end;
  398.  
  399.  
  400. {
  401.   Move the orgin so that when point is rotated by alpha, the rect
  402.   between point and orgin stays in the visible quadrant.
  403. }
  404. function TranslateQuad2D(const alpha :double; const orgin, point :TPoint): TPoint;
  405. var
  406.    alphacos: Extended;
  407.    alphasin: Extended;
  408.    moveby:   TPoint;
  409. begin
  410.    alphasin := sin(alpha);
  411.    alphacos := cos(alpha);
  412.  
  413.    if alphasin >= 0 then
  414.    begin
  415.       if alphacos >= 0 then
  416.       begin
  417.          // 1. Quadrant
  418.          moveby.x := 0;
  419.          moveby.y := Round(alphasin*point.x);
  420.       end
  421.       else
  422.       begin
  423.          // 2. Quadrant
  424.          moveby.x := -Round(alphacos*point.x);
  425.          moveby.y := Round(alphasin*point.x - alphacos*point.y);
  426.       end;
  427.    end
  428.    else
  429.    begin
  430.       if alphacos >= 0 then
  431.       begin
  432.          // 4. quadrant
  433.          moveby.x := -Round(alphasin*point.y);
  434.          moveby.y := 0;
  435.       end
  436.       else
  437.       begin
  438.          // 3. quadrant
  439.          moveby.x := -Round(alphacos*point.x) - Round(alphasin*point.y);
  440.          moveby.y := -Round(alphacos*point.y);
  441.       end;
  442.    end;
  443.    Result := Translate2D(orgin, moveby);
  444. end;
  445.  
  446.  
  447. constructor TfrBarcode.Create(Owner:TComponent);
  448. begin
  449.   inherited Create(owner);
  450.   FAngle := 0.0;
  451.   FRatio := 2.0;
  452.   FModul := 1;
  453.   FTyp   := bcCodeEAN13;
  454.   FCheckSum := FALSE;
  455.   FCheckSumMethod := csmModulo10;
  456.   FColor    := clWhite;
  457.   FColorBar := clBlack;
  458. end;
  459.  
  460.  
  461. procedure TfrBarcode.Assign(Source: TPersistent);
  462. var
  463.    BSource : TfrBarcode;
  464. begin
  465.    if Source is TfrBarcode then
  466.    begin
  467.       BSource    := TfrBarcode(Source);
  468.       FHeight    := BSource.FHeight;
  469.       FText      := BSource.FText;
  470.       FTop       := BSource.FTop;
  471.       FLeft      := BSource.FLeft;
  472.       FModul     := BSource.FModul;
  473.       FRatio     := BSource.FRatio;
  474.       FTyp       := BSource.FTyp;
  475.       FCheckSum  := BSource.FCheckSum;
  476.       FAngle     := BSource.FAngle;
  477.       FColor     := BSource.FColor;
  478.       FColorBar  := BSource.FColorBar;
  479.       FCheckSumMethod := BSource.FCheckSumMethod;
  480.       FOnChange  := BSource.FOnChange;
  481.    end;
  482. end;
  483.  
  484.  
  485.  
  486. { set Modul Width  }
  487. procedure TfrBarcode.SetModul(v:integer);
  488. begin
  489.   if (v >= 1) and (v < 50) then
  490.    begin
  491.     FModul := v;
  492.       DoChange;
  493.    end;
  494. end;
  495.  
  496.  
  497. {
  498. calculate the width and the linetype of a sigle bar
  499.  
  500.  
  501.   Code   Line-Color      Width               Height
  502. ------------------------------------------------------------------
  503.   '0'   white           100%                full
  504.   '1'   white           100%*Ratio          full
  505.   '2'   white           150%*Ratio          full
  506.   '3'   white           200%*Ratio          full
  507.   '5'   black           100%                full
  508.   '6'   black           100%*Ratio          full
  509.   '7'   black           150%*Ratio          full
  510.   '8'   black           200%*Ratio          full
  511.   'A'   black           100%                2/5  (used for PostNet)
  512.   'B'   black           100%*Ratio          2/5  (used for PostNet)
  513.   'C'   black           150%*Ratio          2/5  (used for PostNet)
  514.   'D'   black           200%*Ratio          2/5  (used for PostNet)
  515. }
  516. procedure TfrBarcode.OneBarProps(code:char; var Width:integer; var lt:TfrBarLineType);
  517. begin
  518.   case code of
  519.     '0': begin width := modules[0]; lt := white; end;
  520.     '1': begin width := modules[1]; lt := white; end;
  521.     '2': begin width := modules[2]; lt := white; end;
  522.     '3': begin width := modules[3]; lt := white; end;
  523.  
  524.  
  525.     '5': begin width := modules[0]; lt := black; end;
  526.     '6': begin width := modules[1]; lt := black; end;
  527.     '7': begin width := modules[2]; lt := black; end;
  528.     '8': begin width := modules[3]; lt := black; end;
  529.  
  530.     'A': begin width := modules[0]; lt := black_half; end;
  531.     'B': begin width := modules[1]; lt := black_half; end;
  532.     'C': begin width := modules[2]; lt := black_half; end;
  533.     'D': begin width := modules[3]; lt := black_half; end;
  534.   else
  535.     begin
  536.    {something went wrong  :-(  }
  537.    {mistyped pattern table}
  538.     raise Exception.CreateFmt('%s: internal Error', [self.ClassName]);
  539.     end;
  540.   end;
  541. end;
  542.  
  543.  
  544. function TfrBarcode.MakeData : string;
  545. var
  546.   i : integer;
  547. begin
  548.   {calculate the with of the different lines (modules)}
  549.   MakeModules;
  550.  
  551.  
  552.   {numeric barcode type ?}
  553.   if BCdata[Typ].num then
  554.   begin
  555.    FText := Trim(FText); {remove blanks}
  556.     for i := 1 to Length(Ftext) do
  557.       if (FText[i] > '9') or (FText[i] < '0') then
  558.         raise Exception.Create('Barcode must be numeric');
  559.   end;
  560.  
  561.  
  562.   {get the pattern of the barcode}
  563.   case Typ of
  564.     bcCode_2_5_interleaved: Result := Code_2_5_interleaved;
  565.     bcCode_2_5_industrial:  Result := Code_2_5_industrial;
  566.     bcCode_2_5_matrix:      Result := Code_2_5_matrix;
  567.     bcCode39:               Result := Code_39;
  568.     bcCode39Extended:       Result := Code_39Extended;
  569.     bcCode128A,
  570.     bcCode128B,
  571.     bcCode128C,
  572.     bcCodeEAN128A,
  573.     bcCodeEAN128B,
  574.     bcCodeEAN128C:          Result := Code_128;
  575.     bcCode93:               Result := Code_93;
  576.     bcCode93Extended:       Result := Code_93Extended;
  577.     bcCodeMSI:              Result := Code_MSI;
  578.     bcCodePostNet:          Result := Code_PostNet;
  579.     bcCodeCodabar:          Result := Code_Codabar;
  580.     bcCodeEAN8:             Result := Code_EAN8;
  581.     bcCodeEAN13:            Result := Code_EAN13;
  582.     bcCodeUPC_A:            Result := Code_UPC_A;
  583.     bcCodeUPC_E0:           Result := Code_UPC_E0;
  584.     bcCodeUPC_E1:           Result := Code_UPC_E1;
  585.     bcCodeUPC_Supp2:        Result := Code_Supp2;
  586.     bcCodeUPC_Supp5:        Result := Code_Supp5;
  587.   else
  588.     raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]);
  589.   end;
  590.  
  591. {
  592. Showmessage(Format('Data <%s>', [Result]));
  593. }
  594. end;
  595.  
  596.  
  597.  
  598. function TfrBarcode.GetWidth:integer;
  599. var
  600.   data : string;
  601.   i : integer;
  602.   w : integer;
  603.   lt : TfrBarLineType;
  604. begin
  605.   Result := 0;
  606.  
  607.   {get barcode pattern}
  608.   data := MakeData;
  609.  
  610.   for i:=1 to Length(data) do  {examine the pattern string}
  611.   begin
  612.     OneBarProps(data[i], w, lt);
  613.     Inc(Result, w);
  614.   end;
  615. end;
  616.  
  617. procedure TfrBarcode.SetWidth(Value :integer);
  618. var
  619.   data : string;
  620.   i : integer;
  621.   w, wtotal : integer;
  622.   lt : TfrBarLineType;
  623. begin
  624.   wtotal := 0;
  625.  
  626.   {get barcode pattern}
  627.   data := MakeData;
  628.  
  629.   for i:=1 to Length(data) do  {examine the pattern string}
  630.   begin
  631.     OneBarProps(data[i], w, lt);
  632.     Inc(wtotal, w);
  633.   end;
  634.  
  635.  
  636.   {
  637.   wtotal:  current width of barcode
  638.   Value :  new width of barcode
  639.  
  640.  
  641.  
  642.   }
  643.  
  644.   if wtotal > 0 then  { don't divide by 0 ! }
  645.     SetModul((FModul * Value) div wtotal);
  646. end;
  647.  
  648.  
  649.  
  650. function TfrBarcode.DoCheckSumming(const data : string):string;
  651. begin
  652.   case FCheckSumMethod of
  653.  
  654.     csmNone:
  655.       Result := data;
  656.     csmModulo10:
  657.       Result := CheckSumModulo10(data);
  658.  
  659.   end;
  660. end;
  661.  
  662.  
  663.  
  664.  
  665. {
  666. ////////////////////////////// EAN /////////////////////////////////////////
  667. }
  668.  
  669.  
  670. {
  671. ////////////////////////////// EAN8 /////////////////////////////////////////
  672. }
  673.  
  674. {Pattern for Barcode EAN Charset A}
  675.      {L1   S1   L2   S2}
  676. const tabelle_EAN_A:array['0'..'9'] of string =
  677.   (
  678.   ('2605'),    { 0 }
  679.   ('1615'),    { 1 }
  680.   ('1516'),    { 2 }
  681.   ('0805'),    { 3 }
  682.   ('0526'),    { 4 }
  683.   ('0625'),    { 5 }
  684.   ('0508'),    { 6 }
  685.   ('0706'),    { 7 }
  686.   ('0607'),    { 8 }
  687.   ('2506')     { 9 }
  688.   );
  689.  
  690. {Pattern for Barcode EAN Charset C}
  691.      {S1   L1   S2   L2}
  692. const tabelle_EAN_C:array['0'..'9'] of string =
  693.   (
  694.   ('7150' ),    { 0 }
  695.   ('6160' ),    { 1 }
  696.   ('6061' ),    { 2 }
  697.   ('5350' ),    { 3 }
  698.   ('5071' ),    { 4 }
  699.   ('5170' ),    { 5 }
  700.   ('5053' ),    { 6 }
  701.   ('5251' ),    { 7 }
  702.   ('5152' ),    { 8 }
  703.   ('7051' )     { 9 }
  704.   );
  705.  
  706.  
  707. function TfrBarcode.Code_EAN8:string;
  708. var
  709.   i : integer;
  710.   tmp : String;
  711. begin
  712.   if FCheckSum then
  713.   begin
  714.     tmp := SetLen(7);
  715.     tmp := DoCheckSumming(copy(tmp,length(tmp)-6,7));
  716.   end
  717.   else
  718.     tmp := SetLen(8);
  719.  
  720.   Assert(Length(tmp)=8, 'Invalid Text len (EAN8)');
  721.  
  722.   result := '505';   {Startcode}
  723.  
  724.   for i:=1 to 4 do
  725.     result := result + tabelle_EAN_A[tmp[i]] ;
  726.  
  727.   result := result + '05050';   {Center Guard Pattern}
  728.  
  729.   for i:=5 to 8 do
  730.     result := result + tabelle_EAN_C[tmp[i]] ;
  731.  
  732.   result := result + '505';   {Stopcode}
  733. end;
  734.  
  735. {////////////////////////////// EAN13 ///////////////////////////////////////}
  736.  
  737. {Pattern for Barcode EAN Zeichensatz B}
  738.      {L1   S1   L2   S2}
  739. const tabelle_EAN_B:array['0'..'9'] of string =
  740.   (
  741.   ('0517'),    { 0 }
  742.   ('0616'),    { 1 }
  743.   ('1606'),    { 2 }
  744.   ('0535'),    { 3 }
  745.   ('1705'),    { 4 }
  746.   ('0715'),    { 5 }
  747.   ('3505'),    { 6 }
  748.   ('1525'),    { 7 }
  749.   ('2515'),    { 8 }
  750.   ('1507')     { 9 }
  751.   );
  752.  
  753. {Zuordung der Paraitaetsfolgen fⁿr EAN13}
  754. const tabelle_ParityEAN13:array[0..9, 1..6] of char =
  755.   (
  756.   ('A', 'A', 'A', 'A', 'A', 'A'),    { 0 }
  757.   ('A', 'A', 'B', 'A', 'B', 'B'),    { 1 }
  758.   ('A', 'A', 'B', 'B', 'A', 'B'),    { 2 }
  759.   ('A', 'A', 'B', 'B', 'B', 'A'),    { 3 }
  760.   ('A', 'B', 'A', 'A', 'B', 'B'),    { 4 }
  761.   ('A', 'B', 'B', 'A', 'A', 'B'),    { 5 }
  762.   ('A', 'B', 'B', 'B', 'A', 'A'),    { 6 }
  763.   ('A', 'B', 'A', 'B', 'A', 'B'),    { 7 }
  764.   ('A', 'B', 'A', 'B', 'B', 'A'),    { 8 }
  765.   ('A', 'B', 'B', 'A', 'B', 'A')     { 9 }
  766.   );
  767.  
  768. function TfrBarcode.Code_EAN13:string;
  769. var
  770.   i, LK: integer;
  771.   tmp : String;
  772. begin
  773.   if FCheckSum then
  774.   begin
  775.     tmp := SetLen(12);
  776.     tmp := DoCheckSumming(tmp);
  777.   end
  778.   else
  779.     tmp := SetLen(13);
  780.  
  781.   Assert(Length(tmp) = 13, 'Invalid Text len (EAN13)');
  782.   FText := tmp;
  783.  
  784.   LK := StrToInt(tmp[1]);
  785.   tmp := copy(tmp,2,12);
  786.  
  787.   result := '505';   {Startcode}
  788.  
  789.   for i:=1 to 6 do
  790.   begin
  791.     case tabelle_ParityEAN13[LK,i] of
  792.       'A' : result := result + tabelle_EAN_A[tmp[i]];
  793.       'B' : result := result + tabelle_EAN_B[tmp[i]] ;
  794.       'C' : result := result + tabelle_EAN_C[tmp[i]] ;
  795.   end;
  796.   end;
  797.  
  798.   result := result + '05050';   {Center Guard Pattern}
  799.  
  800.   for i:=7 to 12 do
  801.     result := result + tabelle_EAN_C[tmp[i]] ;
  802.  
  803.     result := result + '505';   {Stopcode}
  804. end;
  805.  
  806. {Pattern for Barcode 2 of 5}
  807. const tabelle_2_5:array['0'..'9', 1..5] of char =
  808.   (
  809.   ('0', '0', '1', '1', '0'),    {'0'}
  810.   ('1', '0', '0', '0', '1'),    {'1'}
  811.   ('0', '1', '0', '0', '1'),    {'2'}
  812.   ('1', '1', '0', '0', '0'),    {'3'}
  813.   ('0', '0', '1', '0', '1'),    {'4'}
  814.   ('1', '0', '1', '0', '0'),    {'5'}
  815.   ('0', '1', '1', '0', '0'),    {'6'}
  816.   ('0', '0', '0', '1', '1'),    {'7'}
  817.   ('1', '0', '0', '1', '0'),    {'8'}
  818.   ('0', '1', '0', '1', '0')     {'9'}
  819.   );
  820.  
  821. function TfrBarcode.Code_2_5_interleaved:string;
  822. var
  823.   i, j: integer;
  824.   c : char;
  825.  
  826. begin
  827.   result := '5050';   {Startcode}
  828.  
  829.   for i:=1 to Length(FText) div 2 do
  830.   begin
  831.     for j:= 1 to 5 do
  832.     begin
  833.       if tabelle_2_5[FText[i*2-1], j] = '1' then
  834.         c := '6'
  835.       else
  836.         c := '5';
  837.       result := result + c;
  838.       if tabelle_2_5[FText[i*2], j] = '1' then
  839.         c := '1'
  840.       else
  841.         c := '0';
  842.       result := result + c;
  843.     end;
  844.   end;
  845.  
  846.   result := result + '605';    {Stopcode}
  847. end;
  848.  
  849.  
  850. function TfrBarcode.Code_2_5_industrial:string;
  851. var
  852.   i, j: integer;
  853. begin
  854.   result := '606050';   {Startcode}
  855.  
  856.   for i:=1 to Length(FText) do
  857.   begin
  858.     for j:= 1 to 5 do
  859.     begin
  860.     if tabelle_2_5[FText[i], j] = '1' then
  861.       result := result + '60'
  862.     else
  863.       result := result + '50';
  864.     end;
  865.   end;
  866.  
  867.   result := result + '605060';   {Stopcode}
  868. end;
  869.  
  870. function TfrBarcode.Code_2_5_matrix:string;
  871. var
  872.   i, j: integer;
  873.   c :char;
  874. begin
  875.   result := '705050';   {Startcode}
  876.  
  877.   for i:=1 to Length(FText) do
  878.   begin
  879.     for j:= 1 to 5 do
  880.     begin
  881.       if tabelle_2_5[FText[i], j] = '1' then
  882.         c := '1'
  883.       else
  884.         c := '0';
  885.  
  886.     {Falls i ungerade ist dann mache Lⁿcke zu Strich}
  887.       if odd(j) then
  888.         c := chr(ord(c)+5);
  889.       result := result + c;
  890.     end;
  891.    result := result + '0';   {Lⁿcke zwischen den Zeichen}
  892.   end;
  893.  
  894.   result := result + '70505';   {Stopcode}
  895. end;
  896.  
  897.  
  898. function TfrBarcode.Code_39:string;
  899.  
  900. type TCode39 =
  901.   record
  902.     c : char;
  903.     data : array[0..9] of char;
  904.     chk: shortint;
  905.   end;
  906.  
  907. const tabelle_39: array[0..43] of TCode39 = (
  908.   ( c:'0'; data:'505160605'; chk:0 ),
  909.   ( c:'1'; data:'605150506'; chk:1 ),
  910.   ( c:'2'; data:'506150506'; chk:2 ),
  911.   ( c:'3'; data:'606150505'; chk:3 ),
  912.   ( c:'4'; data:'505160506'; chk:4 ),
  913.   ( c:'5'; data:'605160505'; chk:5 ),
  914.   ( c:'6'; data:'506160505'; chk:6 ),
  915.   ( c:'7'; data:'505150606'; chk:7 ),
  916.   ( c:'8'; data:'605150605'; chk:8 ),
  917.   ( c:'9'; data:'506150605'; chk:9 ),
  918.   ( c:'A'; data:'605051506'; chk:10),
  919.   ( c:'B'; data:'506051506'; chk:11),
  920.   ( c:'C'; data:'606051505'; chk:12),
  921.   ( c:'D'; data:'505061506'; chk:13),
  922.   ( c:'E'; data:'605061505'; chk:14),
  923.   ( c:'F'; data:'506061505'; chk:15),
  924.   ( c:'G'; data:'505051606'; chk:16),
  925.   ( c:'H'; data:'605051605'; chk:17),
  926.   ( c:'I'; data:'506051605'; chk:18),
  927.   ( c:'J'; data:'505061605'; chk:19),
  928.   ( c:'K'; data:'605050516'; chk:20),
  929.   ( c:'L'; data:'506050516'; chk:21),
  930.   ( c:'M'; data:'606050515'; chk:22),
  931.   ( c:'N'; data:'505060516'; chk:23),
  932.   ( c:'O'; data:'605060515'; chk:24),
  933.   ( c:'P'; data:'506060515'; chk:25),
  934.   ( c:'Q'; data:'505050616'; chk:26),
  935.   ( c:'R'; data:'605050615'; chk:27),
  936.   ( c:'S'; data:'506050615'; chk:28),
  937.   ( c:'T'; data:'505060615'; chk:29),
  938.   ( c:'U'; data:'615050506'; chk:30),
  939.   ( c:'V'; data:'516050506'; chk:31),
  940.   ( c:'W'; data:'616050505'; chk:32),
  941.   ( c:'X'; data:'515060506'; chk:33),
  942.   ( c:'Y'; data:'615060505'; chk:34),
  943.   ( c:'Z'; data:'516060505'; chk:35),
  944.   ( c:'-'; data:'515050606'; chk:36),
  945.   ( c:'.'; data:'615050605'; chk:37),
  946.   ( c:' '; data:'516050605'; chk:38),
  947.   ( c:'*'; data:'515060605'; chk:0 ),
  948.   ( c:'$'; data:'515151505'; chk:39),
  949.   ( c:'/'; data:'515150515'; chk:40),
  950.   ( c:'+'; data:'515051515'; chk:41),
  951.   ( c:'%'; data:'505151515'; chk:42)
  952.   );
  953.  
  954.  
  955. function FindIdx(z:char):integer;
  956. var
  957.   i:integer;
  958. begin
  959.   for i:=0 to High(tabelle_39) do
  960.   begin
  961.     if z = tabelle_39[i].c then
  962.     begin
  963.       result := i;
  964.       exit;
  965.     end;
  966.   end;
  967.   result := -1;
  968. end;
  969.  
  970. var
  971.   i, idx : integer;
  972.   checksum:integer;
  973.  
  974. begin
  975.   checksum := 0;
  976.   {Startcode}
  977.   result := tabelle_39[FindIdx('*')].data + '0';
  978.  
  979.   for i:=1 to Length(FText) do
  980.   begin
  981.     idx := FindIdx(FText[i]);
  982.     if idx < 0 then
  983.       continue;
  984.     result := result + tabelle_39[idx].data + '0';
  985.     Inc(checksum, tabelle_39[idx].chk);
  986.   end;
  987.  
  988.   {Calculate Checksum Data}
  989.   if FCheckSum then
  990.     begin
  991.     checksum := checksum mod 43;
  992.     for i:=0 to High(tabelle_39) do
  993.       if checksum = tabelle_39[i].chk then
  994.       begin
  995.         result := result + tabelle_39[i].data + '0';
  996.         break;
  997.       end;
  998.     end;
  999.  
  1000.   {Stopcode}
  1001.   result := result + tabelle_39[FindIdx('*')].data;
  1002. end;
  1003.  
  1004. function TfrBarcode.Code_39Extended:string;
  1005.  
  1006. const code39x : array[0..127] of string[2] =
  1007.   (
  1008.   ('%U'), ('$A'), ('$B'), ('$C'), ('$D'), ('$E'), ('$F'), ('$G'),
  1009.   ('$H'), ('$I'), ('$J'), ('$K'), ('$L'), ('$M'), ('$N'), ('$O'),
  1010.   ('$P'), ('$Q'), ('$R'), ('$S'), ('$T'), ('$U'), ('$V'), ('$W'),
  1011.   ('$X'), ('$Y'), ('$Z'), ('%A'), ('%B'), ('%C'), ('%D'), ('%E'),
  1012.    (' '), ('/A'), ('/B'), ('/C'), ('/D'), ('/E'), ('/F'), ('/G'),
  1013.   ('/H'), ('/I'), ('/J'), ('/K'), ('/L'), ('/M'), ('/N'), ('/O'),
  1014.   ( '0'),  ('1'),  ('2'),  ('3'),  ('4'),  ('5'),  ('6'),  ('7'),
  1015.    ('8'),  ('9'), ('/Z'), ('%F'), ('%G'), ('%H'), ('%I'), ('%J'),
  1016.   ('%V'),  ('A'),  ('B'),  ('C'),  ('D'),  ('E'),  ('F'),  ('G'),
  1017.    ('H'),  ('I'),  ('J'),  ('K'),  ('L'),  ('M'),  ('N'),  ('O'),
  1018.    ('P'),  ('Q'),  ('R'),  ('S'),  ('T'),  ('U'),  ('V'),  ('W'),
  1019.    ('X'),  ('Y'),  ('Z'), ('%K'), ('%L'), ('%M'), ('%N'), ('%O'),
  1020.   ('%W'), ('+A'), ('+B'), ('+C'), ('+D'), ('+E'), ('+F'), ('+G'),
  1021.   ('+H'), ('+I'), ('+J'), ('+K'), ('+L'), ('+M'), ('+N'), ('+O'),
  1022.   ('+P'), ('+Q'), ('+R'), ('+S'), ('+T'), ('+U'), ('+V'), ('+W'),
  1023.   ('+X'), ('+Y'), ('+Z'), ('%P'), ('%Q'), ('%R'), ('%S'), ('%T')
  1024.   );
  1025.  
  1026.  
  1027. var
  1028.   save:string;
  1029.   i : integer;
  1030. begin
  1031.   save := FText;
  1032.   FText := '';
  1033.  
  1034.   for i:=1 to Length(save) do
  1035.   begin
  1036.     if ord(save[i]) <= 127 then
  1037.       FText := FText + code39x[ord(save[i])];
  1038.   end;
  1039.   result := Code_39;
  1040.   FText := save;
  1041. end;
  1042.  
  1043.  
  1044.  
  1045. {
  1046. Code 128
  1047. }
  1048. function TfrBarcode.Code_128:string;
  1049. type TCode128 =
  1050.   record
  1051.     a, b : char;
  1052.     c : string[2];
  1053.     data : string[6];
  1054.   end;
  1055.  
  1056. const tabelle_128: array[0..102] of TCode128 = (
  1057.   ( a:' '; b:' '; c:'00'; data:'212222' ),
  1058.   ( a:'!'; b:'!'; c:'01'; data:'222122' ),
  1059.   ( a:'"'; b:'"'; c:'02'; data:'222221' ),
  1060.   ( a:'#'; b:'#'; c:'03'; data:'121223' ),
  1061.   ( a:'$'; b:'$'; c:'04'; data:'121322' ),
  1062.   ( a:'%'; b:'%'; c:'05'; data:'131222' ),
  1063.   ( a:'&'; b:'&'; c:'06'; data:'122213' ),
  1064.   ( a:''''; b:''''; c:'07'; data:'122312' ),
  1065.   ( a:'('; b:'('; c:'08'; data:'132212' ),
  1066.   ( a:')'; b:')'; c:'09'; data:'221213' ),
  1067.   ( a:'*'; b:'*'; c:'10'; data:'221312' ),
  1068.   ( a:'+'; b:'+'; c:'11'; data:'231212' ),
  1069.   ( a:'┤'; b:'┤'; c:'12'; data:'112232' ),
  1070.   ( a:'-'; b:'-'; c:'13'; data:'122132' ),
  1071.   ( a:'.'; b:'.'; c:'14'; data:'122231' ),
  1072.   ( a:'/'; b:'/'; c:'15'; data:'113222' ),
  1073.   ( a:'0'; b:'0'; c:'16'; data:'123122' ),
  1074.   ( a:'1'; b:'1'; c:'17'; data:'123221' ),
  1075.   ( a:'2'; b:'2'; c:'18'; data:'223211' ),
  1076.   ( a:'3'; b:'3'; c:'19'; data:'221132' ),
  1077.   ( a:'4'; b:'4'; c:'20'; data:'221231' ),
  1078.   ( a:'5'; b:'5'; c:'21'; data:'213212' ),
  1079.   ( a:'6'; b:'6'; c:'22'; data:'223112' ),
  1080.   ( a:'7'; b:'7'; c:'23'; data:'312131' ),
  1081.   ( a:'8'; b:'8'; c:'24'; data:'311222' ),
  1082.   ( a:'9'; b:'9'; c:'25'; data:'321122' ),
  1083.   ( a:':'; b:':'; c:'26'; data:'321221' ),
  1084.   ( a:';'; b:';'; c:'27'; data:'312212' ),
  1085.   ( a:'<'; b:'<'; c:'28'; data:'322112' ),
  1086.   ( a:'='; b:'='; c:'29'; data:'322211' ),
  1087.   ( a:'>'; b:'>'; c:'30'; data:'212123' ),
  1088.   ( a:'?'; b:'?'; c:'31'; data:'212321' ),
  1089.   ( a:'@'; b:'@'; c:'32'; data:'232121' ),
  1090.   ( a:'A'; b:'A'; c:'33'; data:'111323' ),
  1091.   ( a:'B'; b:'B'; c:'34'; data:'131123' ),
  1092.   ( a:'C'; b:'C'; c:'35'; data:'131321' ),
  1093.   ( a:'D'; b:'D'; c:'36'; data:'112313' ),
  1094.   ( a:'E'; b:'E'; c:'37'; data:'132113' ),
  1095.   ( a:'F'; b:'F'; c:'38'; data:'132311' ),
  1096.   ( a:'G'; b:'G'; c:'39'; data:'211313' ),
  1097.   ( a:'H'; b:'H'; c:'40'; data:'231113' ),
  1098.   ( a:'I'; b:'I'; c:'41'; data:'231311' ),
  1099.   ( a:'J'; b:'J'; c:'42'; data:'112133' ),
  1100.   ( a:'K'; b:'K'; c:'43'; data:'112331' ),
  1101.   ( a:'L'; b:'L'; c:'44'; data:'132131' ),
  1102.   ( a:'M'; b:'M'; c:'45'; data:'113123' ),
  1103.   ( a:'N'; b:'N'; c:'46'; data:'113321' ),
  1104.   ( a:'O'; b:'O'; c:'47'; data:'133121' ),
  1105.   ( a:'P'; b:'P'; c:'48'; data:'313121' ),
  1106.   ( a:'Q'; b:'Q'; c:'49'; data:'211331' ),
  1107.   ( a:'R'; b:'R'; c:'50'; data:'231131' ),
  1108.   ( a:'S'; b:'S'; c:'51'; data:'213113' ),
  1109.   ( a:'T'; b:'T'; c:'52'; data:'213311' ),
  1110.   ( a:'U'; b:'U'; c:'53'; data:'213131' ),
  1111.   ( a:'V'; b:'V'; c:'54'; data:'311123' ),
  1112.   ( a:'W'; b:'W'; c:'55'; data:'311321' ),
  1113.   ( a:'X'; b:'X'; c:'56'; data:'331121' ),
  1114.   ( a:'Y'; b:'Y'; c:'57'; data:'312113' ),
  1115.   ( a:'Z'; b:'Z'; c:'58'; data:'312311' ),
  1116.   ( a:'['; b:'['; c:'59'; data:'332111' ),
  1117.   ( a:'\'; b:'\'; c:'60'; data:'314111' ),
  1118.   ( a:']'; b:']'; c:'61'; data:'221411' ),
  1119.   ( a:'^'; b:'^'; c:'62'; data:'431111' ),
  1120.   ( a:'_'; b:'_'; c:'63'; data:'111224' ),
  1121.   ( a:' '; b:'`'; c:'64'; data:'111422' ),
  1122.   ( a:' '; b:'a'; c:'65'; data:'121124' ),
  1123.   ( a:' '; b:'b'; c:'66'; data:'121421' ),
  1124.   ( a:' '; b:'c'; c:'67'; data:'141122' ),
  1125.   ( a:' '; b:'d'; c:'68'; data:'141221' ),
  1126.   ( a:' '; b:'e'; c:'69'; data:'112214' ),
  1127.   ( a:' '; b:'f'; c:'70'; data:'112412' ),
  1128.   ( a:' '; b:'g'; c:'71'; data:'122114' ),
  1129.   ( a:' '; b:'h'; c:'72'; data:'122411' ),
  1130.   ( a:' '; b:'i'; c:'73'; data:'142112' ),
  1131.   ( a:' '; b:'j'; c:'74'; data:'142211' ),
  1132.   ( a:' '; b:'k'; c:'75'; data:'241211' ),
  1133.   ( a:' '; b:'l'; c:'76'; data:'221114' ),
  1134.   ( a:' '; b:'m'; c:'77'; data:'413111' ),
  1135.   ( a:' '; b:'n'; c:'78'; data:'241112' ),
  1136.   ( a:' '; b:'o'; c:'79'; data:'134111' ),
  1137.   ( a:' '; b:'p'; c:'80'; data:'111242' ),
  1138.   ( a:' '; b:'q'; c:'81'; data:'121142' ),
  1139.   ( a:' '; b:'r'; c:'82'; data:'121241' ),
  1140.   ( a:' '; b:'s'; c:'83'; data:'114212' ),
  1141.   ( a:' '; b:'t'; c:'84'; data:'124112' ),
  1142.   ( a:' '; b:'u'; c:'85'; data:'124211' ),
  1143.   ( a:' '; b:'v'; c:'86'; data:'411212' ),
  1144.   ( a:' '; b:'w'; c:'87'; data:'421112' ),
  1145.   ( a:' '; b:'x'; c:'88'; data:'421211' ),
  1146.   ( a:' '; b:'y'; c:'89'; data:'212141' ),
  1147.   ( a:' '; b:'z'; c:'90'; data:'214121' ),
  1148.   ( a:' '; b:'{'; c:'91'; data:'412121' ),
  1149.   ( a:' '; b:'|'; c:'92'; data:'111143' ),
  1150.   ( a:' '; b:'}'; c:'93'; data:'111341' ),
  1151.   ( a:' '; b:'~'; c:'94'; data:'131141' ),
  1152.   ( a:' '; b:' '; c:'95'; data:'114113' ),
  1153.   ( a:' '; b:' '; c:'96'; data:'114311' ),
  1154.   ( a:' '; b:' '; c:'97'; data:'411113' ),
  1155.   ( a:' '; b:' '; c:'98'; data:'411311' ),
  1156.   ( a:' '; b:' '; c:'99'; data:'113141' ),
  1157.   ( a:' '; b:' '; c:'  '; data:'114131' ),
  1158.   ( a:' '; b:' '; c:'  '; data:'311141' ),
  1159.   ( a:' '; b:' '; c:'  '; data:'411131' )      { FNC1 }
  1160.   );
  1161.  
  1162. StartA = '211412';
  1163. StartB = '211214';
  1164. StartC = '211232';
  1165. Stop   = '2331112';
  1166.  
  1167.  
  1168.  
  1169.  
  1170. {find Code 128 Codeset A or B}
  1171. function Find_Code128AB(c:char):integer;
  1172. var
  1173.   i:integer;
  1174.   v:char;
  1175. begin
  1176.   for i:=0 to High(tabelle_128) do
  1177.   begin
  1178.     if FTyp = bcCode128A then
  1179.       v := tabelle_128[i].a
  1180.     else
  1181.       v := tabelle_128[i].b;
  1182.  
  1183.     if c = v then
  1184.     begin
  1185.       result := i;
  1186.       exit;
  1187.     end;
  1188.   end;
  1189.   result := -1;
  1190. end;
  1191.  
  1192. { find Code 128 Codeset C }
  1193. function Find_Code128C(c:string):integer;
  1194.   var  i:integer;
  1195.   begin
  1196.     for i:=0 to High(tabelle_128) do begin
  1197.       if tabelle_128[i].c = c then begin
  1198.        result := i;
  1199.        exit;
  1200.       end;
  1201.     end;
  1202.     result := -1;
  1203.   end;
  1204.  
  1205.  
  1206.  
  1207. var i, j, idx: integer;
  1208.   startcode:string;
  1209.   checksum : integer;
  1210.   codeword_pos : integer;
  1211.  
  1212. begin
  1213.   case FTyp of
  1214.     bcCode128A, bcCodeEAN128A:
  1215.       begin checksum := 103; startcode:= StartA; end;
  1216.     bcCode128B, bcCodeEAN128B:
  1217.       begin checksum := 104; startcode:= StartB; end;
  1218.     bcCode128C, bcCodeEAN128C:
  1219.       begin checksum := 105; startcode:= StartC; end;
  1220.     else
  1221.       raise Exception.CreateFmt('%s: wrong BarcodeType in Code_128', [self.ClassName]);
  1222.   end;
  1223.  
  1224.   result := startcode;    {Startcode}
  1225.   codeword_pos := 1;
  1226.  
  1227.   case FTyp of
  1228.     bcCodeEAN128A,
  1229.     bcCodeEAN128B,
  1230.     bcCodeEAN128C:
  1231.       begin
  1232.       {
  1233.       special identifier
  1234.       FNC1 = function code 1
  1235.       for EAN 128 barcodes
  1236.       }
  1237.       result := result + tabelle_128[102].data;
  1238.       Inc(checksum, 102*codeword_pos);
  1239.       Inc(codeword_pos);
  1240.       {
  1241.       if there is no checksum at the end of the string
  1242.       the EAN128 needs one (modulo 10)
  1243.       }
  1244.       if FCheckSum then FText:=DoCheckSumming(FTEXT);
  1245.       end;
  1246.   end;
  1247.  
  1248.   if (FTyp = bcCode128C) or (FTyp = bccodeEAN128C) then
  1249.   begin
  1250.     if (Length(FText) mod 2<>0) then FText:='0'+FText;
  1251.     for i:=1 to (Length(FText) div 2) do
  1252.     begin
  1253.       j:=(i-1)*2+1;
  1254.       idx:=Find_Code128C(copy(Ftext,j,2));
  1255.       if idx < 0 then idx := Find_Code128C('00');
  1256.       result := result + tabelle_128[idx].data;
  1257.       Inc(checksum, idx*codeword_pos);
  1258.       Inc(codeword_pos);
  1259.     end;
  1260.   end
  1261.   else
  1262.     for i:=1 to Length(FText) do
  1263.     begin
  1264.       idx := Find_Code128AB(FText[i]);
  1265.       if idx < 0 then
  1266.         idx := Find_Code128AB(' ');
  1267.       result := result + tabelle_128[idx].data;
  1268.       Inc(checksum, idx*codeword_pos);
  1269.       Inc(codeword_pos);
  1270.     end;
  1271.  
  1272.   checksum := checksum mod 103;
  1273.   result := result + tabelle_128[checksum].data;
  1274.  
  1275.   result := result + Stop;      {Stopcode}
  1276.   Result := Convert(Result);
  1277. end;
  1278.  
  1279.  
  1280.  
  1281.  
  1282.  
  1283. function TfrBarcode.Code_93:string;
  1284. type TCode93 =
  1285.   record
  1286.     c : char;
  1287.     data : array[0..5] of char;
  1288.   end;
  1289.  
  1290. const tabelle_93: array[0..46] of TCode93 = (
  1291.   ( c:'0'; data:'131112'  ),
  1292.   ( c:'1'; data:'111213'  ),
  1293.   ( c:'2'; data:'111312'  ),
  1294.   ( c:'3'; data:'111411'  ),
  1295.   ( c:'4'; data:'121113'  ),
  1296.   ( c:'5'; data:'121212'  ),
  1297.   ( c:'6'; data:'121311'  ),
  1298.   ( c:'7'; data:'111114'  ),
  1299.   ( c:'8'; data:'131211'  ),
  1300.   ( c:'9'; data:'141111'  ),
  1301.   ( c:'A'; data:'211113'  ),
  1302.   ( c:'B'; data:'211212'  ),
  1303.   ( c:'C'; data:'211311'  ),
  1304.   ( c:'D'; data:'221112'  ),
  1305.   ( c:'E'; data:'221211'  ),
  1306.   ( c:'F'; data:'231111'  ),
  1307.   ( c:'G'; data:'112113'  ),
  1308.   ( c:'H'; data:'112212'  ),
  1309.   ( c:'I'; data:'112311'  ),
  1310.   ( c:'J'; data:'122112'  ),
  1311.   ( c:'K'; data:'132111'  ),
  1312.   ( c:'L'; data:'111123'  ),
  1313.   ( c:'M'; data:'111222'  ),
  1314.   ( c:'N'; data:'111321'  ),
  1315.   ( c:'O'; data:'121122'  ),
  1316.   ( c:'P'; data:'131121'  ),
  1317.   ( c:'Q'; data:'212112'  ),
  1318.   ( c:'R'; data:'212211'  ),
  1319.   ( c:'S'; data:'211122'  ),
  1320.   ( c:'T'; data:'211221'  ),
  1321.   ( c:'U'; data:'221121'  ),
  1322.   ( c:'V'; data:'222111'  ),
  1323.   ( c:'W'; data:'112122'  ),
  1324.   ( c:'X'; data:'112221'  ),
  1325.   ( c:'Y'; data:'122121'  ),
  1326.   ( c:'Z'; data:'123111'  ),
  1327.   ( c:'-'; data:'121131'  ),
  1328.   ( c:'.'; data:'311112'  ),
  1329.   ( c:' '; data:'311211'  ),
  1330.   ( c:'$'; data:'321111'  ),
  1331.   ( c:'/'; data:'112131'  ),
  1332.   ( c:'+'; data:'113121'  ),
  1333.   ( c:'%'; data:'211131'  ),
  1334.   ( c:'['; data:'121221'  ),   {only used for Extended Code 93}
  1335.   ( c:']'; data:'312111'  ),   {only used for Extended Code 93}
  1336.   ( c:'{'; data:'311121'  ),   {only used for Extended Code 93}
  1337.   ( c:'}'; data:'122211'  )    {only used for Extended Code 93}
  1338.   );
  1339.  
  1340.  
  1341. {find Code 93}
  1342. function Find_Code93(c:char):integer;
  1343. var
  1344.   i:integer;
  1345. begin
  1346.   for i:=0 to High(tabelle_93) do
  1347.   begin
  1348.     if c = tabelle_93[i].c then
  1349.     begin
  1350.       result := i;
  1351.       exit;
  1352.     end;
  1353.   end;
  1354.   result := -1;
  1355. end;
  1356.  
  1357.  
  1358.  
  1359.  
  1360. var
  1361.   i, idx : integer;
  1362.   checkC, checkK,   {Checksums}
  1363.   weightC, weightK : integer;
  1364. begin
  1365.  
  1366.   result := '111141';   {Startcode}
  1367.  
  1368.   for i:=1 to Length(FText) do
  1369.   begin
  1370.     idx := Find_Code93(FText[i]);
  1371.     if idx < 0 then
  1372.       raise Exception.CreateFmt('%s:Code93 bad Data <%s>', [self.ClassName,FText]);
  1373.     result := result + tabelle_93[idx].data;
  1374.   end;
  1375.  
  1376.   checkC := 0;
  1377.   checkK := 0;
  1378.  
  1379.   weightC := 1;
  1380.   weightK := 2;
  1381.  
  1382.   for i:=Length(FText) downto 1 do
  1383.   begin
  1384.     idx := Find_Code93(FText[i]);
  1385.  
  1386.     Inc(checkC, idx*weightC);
  1387.     Inc(checkK, idx*weightK);
  1388.  
  1389.     Inc(weightC);
  1390.     if weightC > 20 then weightC := 1;
  1391.     Inc(weightK);
  1392.     if weightK > 15 then weightC := 1;
  1393.   end;
  1394.  
  1395.   Inc(checkK, checkC);
  1396.  
  1397.   checkC := checkC mod 47;
  1398.   checkK := checkK mod 47;
  1399.  
  1400.   result := result + tabelle_93[checkC].data +
  1401.     tabelle_93[checkK].data;
  1402.  
  1403.   result := result + '1111411';   {Stopcode}
  1404.   Result := Convert(Result);
  1405. end;
  1406.  
  1407.  
  1408.  
  1409.  
  1410.  
  1411. function TfrBarcode.Code_93Extended:string;
  1412. const code93x : array[0..127] of string[2] =
  1413.   (
  1414.   (']U'), ('[A'), ('[B'), ('[C'), ('[D'), ('[E'), ('[F'), ('[G'),
  1415.   ('[H'), ('[I'), ('[J'), ('[K'), ('[L'), ('[M'), ('[N'), ('[O'),
  1416.   ('[P'), ('[Q'), ('[R'), ('[S'), ('[T'), ('[U'), ('[V'), ('[W'),
  1417.   ('[X'), ('[Y'), ('[Z'), (']A'), (']B'), (']C'), (']D'), (']E'),
  1418.    (' '), ('{A'), ('{B'), ('{C'), ('{D'), ('{E'), ('{F'), ('{G'),
  1419.   ('{H'), ('{I'), ('{J'), ('{K'), ('{L'), ('{M'), ('{N'), ('{O'),
  1420.   ( '0'),  ('1'),  ('2'),  ('3'),  ('4'),  ('5'),  ('6'),  ('7'),
  1421.    ('8'),  ('9'), ('{Z'), (']F'), (']G'), (']H'), (']I'), (']J'),
  1422.   (']V'),  ('A'),  ('B'),  ('C'),  ('D'),  ('E'),  ('F'),  ('G'),
  1423.    ('H'),  ('I'),  ('J'),  ('K'),  ('L'),  ('M'),  ('N'),  ('O'),
  1424.    ('P'),  ('Q'),  ('R'),  ('S'),  ('T'),  ('U'),  ('V'),  ('W'),
  1425.    ('X'),  ('Y'),  ('Z'), (']K'), (']L'), (']M'), (']N'), (']O'),
  1426.   (']W'), ('}A'), ('}B'), ('}C'), ('}D'), ('}E'), ('}F'), ('}G'),
  1427.   ('}H'), ('}I'), ('}J'), ('}K'), ('}L'), ('}M'), ('}N'), ('}O'),
  1428.   ('}P'), ('}Q'), ('}R'), ('}S'), ('}T'), ('}U'), ('}V'), ('}W'),
  1429.   ('}X'), ('}Y'), ('}Z'), (']P'), (']Q'), (']R'), (']S'), (']T')
  1430.   );
  1431.  
  1432. var
  1433.   {save:array[0..254] of char;}
  1434.   {old:string;}
  1435.   save : string;
  1436.   i : integer;
  1437. begin
  1438.  {CharToOem(PChar(FText), save);}
  1439.  
  1440.  
  1441.  
  1442.   save := FText;
  1443.   FText := '';
  1444.  
  1445.  
  1446.   for i:=0 to Length(save)-1 do
  1447.   begin
  1448.     if ord(save[i]) <= 127 then
  1449.       FText := FText + code93x[ord(save[i])];
  1450.   end;
  1451.  
  1452.   {Showmessage(Format('Text: <%s>', [FText]));}
  1453.  
  1454.   result := Code_93;
  1455.   FText := save;
  1456. end;
  1457.  
  1458.  
  1459.  
  1460. function TfrBarcode.Code_MSI:string;
  1461. const tabelle_MSI:array['0'..'9'] of string[8] =
  1462.   (
  1463.   ( '51515151' ),    {'0'}
  1464.   ( '51515160' ),    {'1'}
  1465.   ( '51516051' ),    {'2'}
  1466.   ( '51516060' ),    {'3'}
  1467.   ( '51605151' ),    {'4'}
  1468.   ( '51605160' ),    {'5'}
  1469.   ( '51606051' ),    {'6'}
  1470.   ( '51606060' ),    {'7'}
  1471.   ( '60515151' ),    {'8'}
  1472.   ( '60515160' )     {'9'}
  1473.   );
  1474.  
  1475. var
  1476.   i:integer;
  1477.   check_even, check_odd, checksum:integer;
  1478. begin
  1479.   result := '60';    {Startcode}
  1480.   check_even := 0;
  1481.   check_odd  := 0;
  1482.  
  1483.   for i:=1 to Length(FText) do
  1484.   begin
  1485.     if odd(i-1) then
  1486.       check_odd := check_odd*10+ord(FText[i])
  1487.     else
  1488.       check_even := check_even+ord(FText[i]);
  1489.  
  1490.     result := result + tabelle_MSI[FText[i]];
  1491.   end;
  1492.  
  1493.   checksum := quersumme(check_odd*2) + check_even;
  1494.  
  1495.   checksum := checksum mod 10;
  1496.   if checksum > 0 then
  1497.     checksum := 10-checksum;
  1498.  
  1499.   result := result + tabelle_MSI[chr(ord('0')+checksum)];
  1500.  
  1501.   result := result + '515'; {Stopcode}
  1502. end;
  1503.  
  1504.  
  1505.  
  1506. function TfrBarcode.Code_PostNet:string;
  1507. const tabelle_PostNet:array['0'..'9'] of string[10] =
  1508.   (
  1509.   ( '5151A1A1A1' ),    {'0'}
  1510.   ( 'A1A1A15151' ),    {'1'}
  1511.   ( 'A1A151A151' ),    {'2'}
  1512.   ( 'A1A15151A1' ),    {'3'}
  1513.   ( 'A151A1A151' ),    {'4'}
  1514.   ( 'A151A151A1' ),    {'5'}
  1515.   ( 'A15151A1A1' ),    {'6'}
  1516.   ( '51A1A1A151' ),    {'7'}
  1517.   ( '51A1A151A1' ),    {'8'}
  1518.   ( '51A151A1A1' )     {'9'}
  1519.   );
  1520. var
  1521.   i:integer;
  1522. begin
  1523.   result := '51';
  1524.  
  1525.   for i:=1 to Length(FText) do
  1526.   begin
  1527.     result := result + tabelle_PostNet[FText[i]];
  1528.   end;
  1529.   result := result + '5';
  1530. end;
  1531.  
  1532.  
  1533. function TfrBarcode.Code_Codabar:string;
  1534. type TCodabar =
  1535.   record
  1536.     c : char;
  1537.     data : array[0..6] of char;
  1538.   end;
  1539.  
  1540. const tabelle_cb: array[0..19] of TCodabar = (
  1541.   ( c:'1'; data:'5050615'  ),
  1542.   ( c:'2'; data:'5051506'  ),
  1543.   ( c:'3'; data:'6150505'  ),
  1544.   ( c:'4'; data:'5060515'  ),
  1545.   ( c:'5'; data:'6050515'  ),
  1546.   ( c:'6'; data:'5150506'  ),
  1547.   ( c:'7'; data:'5150605'  ),
  1548.   ( c:'8'; data:'5160505'  ),
  1549.   ( c:'9'; data:'6051505'  ),
  1550.   ( c:'0'; data:'5050516'  ),
  1551.   ( c:'-'; data:'5051605'  ),
  1552.   ( c:'$'; data:'5061505'  ),
  1553.   ( c:':'; data:'6050606'  ),
  1554.   ( c:'/'; data:'6060506'  ),
  1555.   ( c:'.'; data:'6060605'  ),
  1556.   ( c:'+'; data:'5060606'  ),
  1557.   ( c:'A'; data:'5061515'  ),
  1558.   ( c:'B'; data:'5151506'  ),
  1559.   ( c:'C'; data:'5051516'  ),
  1560.   ( c:'D'; data:'5051615'  )
  1561.   );
  1562.  
  1563.  
  1564.  
  1565. {find Codabar}
  1566. function Find_Codabar(c:char):integer;
  1567. var
  1568.   i:integer;
  1569. begin
  1570.   for i:=0 to High(tabelle_cb) do
  1571.   begin
  1572.     if c = tabelle_cb[i].c then
  1573.     begin
  1574.       result := i;
  1575.       exit;
  1576.     end;
  1577.   end;
  1578.   result := -1;
  1579. end;
  1580.  
  1581. var
  1582.   i, idx : integer;
  1583. begin
  1584.   result := tabelle_cb[Find_Codabar('A')].data + '0';
  1585.   for i:=1 to Length(FText) do
  1586.   begin
  1587.     idx := Find_Codabar(FText[i]);
  1588.     result := result + tabelle_cb[idx].data + '0';
  1589.   end;
  1590.   result := result + tabelle_cb[Find_Codabar('B')].data;
  1591. end;
  1592.  
  1593.  
  1594.  
  1595. {---------------}
  1596.  
  1597. {Assist function}
  1598. function TfrBarcode.SetLen(pI:byte):string;
  1599. begin
  1600.    if Length(FText) > pI then
  1601.      Result := Copy(FText, 1, pI) else
  1602.      Result := StringOfChar('0', pI-Length(FText)) + FText;
  1603. end;
  1604.  
  1605.  
  1606.  
  1607. function TfrBarcode.Code_UPC_A:string;
  1608. var
  1609.   i : integer;
  1610.   tmp : String;
  1611. begin
  1612.   FText := SetLen(12);
  1613.   if FCheckSum then tmp:=DoCheckSumming(copy(FText,1,11));
  1614.   if FCheckSum then FText:=tmp else tmp:=FText;
  1615.   result := '505';   {Startcode}
  1616.   for i:=1 to 6 do
  1617.     result := result + tabelle_EAN_A[tmp[i]];
  1618.   result := result + '05050';   {Trennzeichen}
  1619.   for i:=7 to 12 do
  1620.     result := result + tabelle_EAN_C[tmp[i]];
  1621.   result := result + '505';   {Stopcode}
  1622. end;
  1623.  
  1624.  
  1625. {UPC E Parity Pattern Table , Number System 0}
  1626. const tabelle_UPC_E0:array['0'..'9', 1..6] of char =
  1627.   (
  1628.   ('E', 'E', 'E', 'o', 'o', 'o' ),    { 0 }
  1629.   ('E', 'E', 'o', 'E', 'o', 'o' ),    { 1 }
  1630.   ('E', 'E', 'o', 'o', 'E', 'o' ),    { 2 }
  1631.   ('E', 'E', 'o', 'o', 'o', 'E' ),    { 3 }
  1632.   ('E', 'o', 'E', 'E', 'o', 'o' ),    { 4 }
  1633.   ('E', 'o', 'o', 'E', 'E', 'o' ),    { 5 }
  1634.   ('E', 'o', 'o', 'o', 'E', 'E' ),    { 6 }
  1635.   ('E', 'o', 'E', 'o', 'E', 'o' ),    { 7 }
  1636.   ('E', 'o', 'E', 'o', 'o', 'E' ),    { 8 }
  1637.   ('E', 'o', 'o', 'E', 'o', 'E' )     { 9 }
  1638.   );
  1639.  
  1640. function TfrBarcode.Code_UPC_E0:string;
  1641. var i,j : integer;
  1642.    tmp : String;
  1643.    c   : char;
  1644. begin
  1645.   FText := SetLen(7);
  1646.   tmp:=DoCheckSumming(copy(FText,1,6));
  1647.   c:=tmp[7];
  1648.   if FCheckSum then FText:=tmp else tmp := FText;
  1649.   result := '505';   {Startcode}
  1650.   for i:=1 to 6 do
  1651.   begin
  1652.     if tabelle_UPC_E0[c,i]='E' then
  1653.     begin
  1654.       for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
  1655.     end
  1656.     else
  1657.     begin
  1658.       result := result + tabelle_EAN_A[tmp[i]];
  1659.     end;
  1660.   end;
  1661.   result := result + '05050';   {Stopcode}
  1662. end;
  1663.  
  1664. function TfrBarcode.Code_UPC_E1:string;
  1665. var i,j : integer;
  1666.    tmp : String;
  1667.    c   : char;
  1668. begin
  1669.   FText := SetLen(7);
  1670.   tmp:=DoCheckSumming(copy(FText,1,6));
  1671.   c:=tmp[7];
  1672.   if FCheckSum then FText:=tmp else tmp := FText;
  1673.   result := '505';   {Startcode}
  1674.   for i:=1 to 6 do
  1675.   begin
  1676.     if tabelle_UPC_E0[c,i]='E' then
  1677.     begin
  1678.       result := result + tabelle_EAN_A[tmp[i]];
  1679.     end
  1680.     else
  1681.     begin
  1682.       for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
  1683.     end;
  1684.   end;
  1685.   result := result + '05050';   {Stopcode}
  1686. end;
  1687.  
  1688. {assist function}
  1689. function getSupp(Nr : String) : String;
  1690. var i,fak,sum : Integer;
  1691.       tmp   : String;
  1692. begin
  1693.   sum := 0;
  1694.   tmp := copy(nr,1,Length(Nr)-1);
  1695.   fak := Length(tmp);
  1696.   for i:=1 to length(tmp) do
  1697.   begin
  1698.     if (fak mod 2) = 0 then
  1699.       sum := sum + (StrToInt(tmp[i])*9)
  1700.     else
  1701.       sum := sum + (StrToInt(tmp[i])*3);
  1702.     dec(fak);
  1703.   end;
  1704.   sum:=((sum mod 10) mod 10) mod 10;
  1705.   result := tmp+IntToStr(sum);
  1706. end;
  1707.  
  1708. function TfrBarcode.Code_Supp5:string;
  1709. var i,j : integer;
  1710.    tmp : String;
  1711.    c   : char;
  1712. begin
  1713.   FText := SetLen(5);
  1714.   tmp:=getSupp(copy(FText,1,5)+'0');
  1715.   c:=tmp[6];
  1716.   if FCheckSum then FText:=tmp else tmp := FText;
  1717.   result := '506';   {Startcode}
  1718.   for i:=1 to 5 do
  1719.   begin
  1720.     if tabelle_UPC_E0[c,(6-5)+i]='E' then
  1721.     begin
  1722.       for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
  1723.     end
  1724.     else
  1725.     begin
  1726.       result := result + tabelle_EAN_A[tmp[i]];
  1727.     end;
  1728.     if i<5 then result:=result+'05'; // character delineator
  1729.   end;
  1730. end;
  1731.  
  1732. function TfrBarcode.Code_Supp2:string;
  1733. var i,j : integer;
  1734.    tmp,mS : String;
  1735. begin
  1736.   FText := SetLen(2);
  1737.   i:=StrToInt(Ftext);
  1738.   case i mod 4 of
  1739.     3: mS:='EE';
  1740.     2: mS:='Eo';
  1741.     1: mS:='oE';
  1742.     0: mS:='oo';
  1743.   end;
  1744.   tmp:=getSupp(copy(FText,1,5)+'0');
  1745.  
  1746.   if FCheckSum then FText:=tmp else tmp := FText;
  1747.   result := '506';   {Startcode}
  1748.   for i:=1 to 2 do
  1749.   begin
  1750.     if mS[i]='E' then
  1751.     begin
  1752.       for j:= 1 to 4 do result := result + tabelle_EAN_C[tmp[i],5-j];
  1753.     end
  1754.     else
  1755.     begin
  1756.       result := result + tabelle_EAN_A[tmp[i]];
  1757.     end;
  1758.     if i<2 then result:=result+'05'; // character delineator
  1759.   end;
  1760. end;
  1761.  
  1762. {---------------}
  1763.  
  1764.  
  1765.  
  1766.  
  1767. procedure TfrBarcode.MakeModules;
  1768. begin
  1769.   case Typ of
  1770.     bcCode_2_5_interleaved,
  1771.     bcCode_2_5_industrial,
  1772.     bcCode39,
  1773.     bcCodeEAN8,
  1774.     bcCodeEAN13,
  1775.     bcCode39Extended,
  1776.     bcCodeCodabar,
  1777.     bcCodeUPC_A,
  1778.     bcCodeUPC_E0,
  1779.     bcCodeUPC_E1,
  1780.     bcCodeUPC_Supp2,
  1781.     bcCodeUPC_Supp5:
  1782.  
  1783.     begin
  1784.       if Ratio < 2.0 then Ratio := 2.0;
  1785.       if Ratio > 3.0 then Ratio := 3.0;
  1786.     end;
  1787.  
  1788.     bcCode_2_5_matrix:
  1789.     begin
  1790.       if Ratio < 2.25 then Ratio := 2.25;
  1791.       if Ratio > 3.0 then Ratio := 3.0;
  1792.     end;
  1793.     bcCode128A,
  1794.     bcCode128B,
  1795.     bcCode128C,
  1796.     bcCode93,
  1797.     bcCode93Extended,
  1798.     bcCodeMSI,
  1799.     bcCodePostNet:    ;
  1800.   end;
  1801.  
  1802.  
  1803.   modules[0] := FModul;
  1804.   modules[1] := Round(FModul*FRatio);
  1805.   modules[2] := modules[1] * 3 div 2;
  1806.   modules[3] := modules[1] * 2;
  1807. end;
  1808.  
  1809.  
  1810.  
  1811.  
  1812.  
  1813. {
  1814. Draw the Barcode
  1815.  
  1816. Parameter :
  1817. 'data' holds the pattern for a Barcode.
  1818. A barcode begins always with a black line and
  1819. ends with a black line.
  1820.  
  1821. The white Lines builds the space between the black Lines.
  1822.  
  1823. A black line must always followed by a white Line and vica versa.
  1824.  
  1825. Examples:
  1826.   '50505'   // 3 thin black Lines with 2 thin white Lines
  1827.   '606'     // 2 fat black Lines with 1 thin white Line
  1828.  
  1829.   '5605015' // Error
  1830.  
  1831.  
  1832. data[] : see procedure OneBarProps
  1833.  
  1834. }
  1835. procedure TfrBarcode.DoLines(data:string; Canvas:TCanvas);
  1836.  
  1837. var i:integer;
  1838.   lt : TfrBarLineType;
  1839.   xadd:integer;
  1840.   width, height:integer;
  1841.   a,b,c,d,     {Edges of a line (we need 4 Point because the line}
  1842.           {is a recangle}
  1843.   orgin : TPoint;
  1844.   alpha:double;
  1845. begin
  1846.   xadd := 0;
  1847.   orgin.x := FLeft;
  1848.   orgin.y := FTop;
  1849.  
  1850.   alpha := FAngle/180.0*pi;
  1851.  
  1852.   { Move the orgin so the entire barcode ends up in the visible region. }
  1853.   orgin := TranslateQuad2D(alpha,orgin,Point(Self.Width,Self.Height));
  1854.  
  1855.   with Canvas do begin
  1856.     Pen.Width := 1;
  1857.  
  1858.    for i:=1 to Length(data) do  {examine the pattern string}
  1859.     begin
  1860.  
  1861.       {
  1862.       input:  pattern code
  1863.       output: Width and Linetype
  1864.       }
  1865.       OneBarProps(data[i], width, lt);
  1866.  
  1867.       if (lt = black) or (lt = black_half) then
  1868.       begin
  1869.         Pen.Color := FColorBar;
  1870.       end
  1871.       else
  1872.       begin
  1873.         Pen.Color := FColor;
  1874.       end;
  1875.       Brush.Color := Pen.Color;
  1876.  
  1877.       if lt = black_half then
  1878.         height := FHeight * 2 div 5
  1879.       else
  1880.         height := FHeight;
  1881.  
  1882.  
  1883.  
  1884.  
  1885.  
  1886.       a.x := xadd;
  1887.       a.y := 0;
  1888.  
  1889.       b.x := xadd;
  1890.       b.y := height;
  1891.  
  1892.     {c.x := xadd+width;}
  1893.     c.x := xadd+Width-1;  {23.04.1999 Line was 1 Pixel too wide}
  1894.       c.y := Height;
  1895.  
  1896.     {d.x := xadd+width;}
  1897.     d.x := xadd+Width-1;  {23.04.1999 Line was 1 Pixel too wide}
  1898.       d.y := 0;
  1899.  
  1900.     {a,b,c,d builds the rectangle we want to draw}
  1901.  
  1902.  
  1903.     {rotate the rectangle}
  1904.       a := Translate2D(Rotate2D(a, alpha), orgin);
  1905.       b := Translate2D(Rotate2D(b, alpha), orgin);
  1906.       c := Translate2D(Rotate2D(c, alpha), orgin);
  1907.       d := Translate2D(Rotate2D(d, alpha), orgin);
  1908.  
  1909.     {draw the rectangle}
  1910.       Polygon([a,b,c,d]);
  1911.  
  1912.       xadd := xadd + width;
  1913.     end;
  1914.   end;
  1915. end;
  1916.  
  1917.  
  1918.  
  1919. procedure TfrBarcode.DrawBarcode(Canvas:TCanvas);
  1920. var
  1921.   data : string;
  1922.   SaveFont: TFont;
  1923.   SavePen: TPen;
  1924.   SaveBrush: TBrush;
  1925. begin
  1926.   Savefont  := TFont.Create;
  1927.   SavePen   := TPen.Create;
  1928.   SaveBrush := TBrush.Create;
  1929.  
  1930.  
  1931.   {get barcode pattern}
  1932.   data := MakeData;
  1933.  
  1934.  
  1935.   try
  1936.    {store Canvas properties}
  1937.     Savefont.Assign(Canvas.Font);
  1938.     SavePen.Assign(Canvas.Pen);
  1939.     SaveBrush.Assign(Canvas.Brush);
  1940.  
  1941.     DoLines(data, Canvas);    {draw the barcode}
  1942.  
  1943.    {restore old Canvas properties}
  1944.     Canvas.Font.Assign(savefont);
  1945.     Canvas.Pen.Assign(SavePen);
  1946.     Canvas.Brush.Assign(SaveBrush);
  1947.   finally
  1948.     Savefont.Free;
  1949.     SavePen.Free;
  1950.     SaveBrush.Free;
  1951.   end;
  1952. end;
  1953.  
  1954.  
  1955. {
  1956.   draw contents and type/name of barcode
  1957.   as human readable text at the left
  1958.   upper edge of the barcode.
  1959.  
  1960.   main use for this procedure is testing.
  1961.  
  1962.   note: this procedure changes Pen and Brush
  1963.   of the current canvas.
  1964. }
  1965.  
  1966.  
  1967. procedure TfrBarcode.DoChange;
  1968. begin
  1969.    if Assigned(FOnChange) then
  1970.       FOnChange(Self);
  1971. end;
  1972.  
  1973. procedure TfrBarcode.SetRatio(const Value: Double);
  1974. begin
  1975.    if Value <> FRatio then
  1976.    begin
  1977.       FRatio := Value;
  1978.       DoChange;
  1979.    end;
  1980. end;
  1981.  
  1982. procedure TfrBarcode.SetTyp(const Value: TfrBarcodeType);
  1983. begin
  1984.    if Value <> FTyp then
  1985.    begin
  1986.       FTyp := Value;
  1987.       DoChange;
  1988.    end;
  1989. end;
  1990.  
  1991. procedure TfrBarcode.SetAngle(const Value: Double);
  1992. begin
  1993.    if Value <> FAngle then
  1994.    begin
  1995.       FAngle := Value;
  1996.       DoChange;
  1997.    end;
  1998. end;
  1999.  
  2000. procedure TfrBarcode.SetText(const Value: string);
  2001. begin
  2002.    if Value <> FText then
  2003.    begin
  2004.       FText := Value;
  2005.       DoChange;
  2006.    end;
  2007. end;
  2008.  
  2009. procedure TfrBarcode.SetTop(const Value: Integer);
  2010. begin
  2011.    if Value <> FTop then
  2012.    begin
  2013.       FTop := Value;
  2014.       DoChange;
  2015.    end;
  2016. end;
  2017.  
  2018. procedure TfrBarcode.SetLeft(const Value: Integer);
  2019. begin
  2020.    if Value <> FLeft then
  2021.    begin
  2022.       FLeft := Value;
  2023.       DoChange;
  2024.    end;
  2025. end;
  2026.  
  2027. procedure TfrBarcode.SetCheckSum(const Value: Boolean);
  2028. begin
  2029.    if Value <> FCheckSum then
  2030.    begin
  2031.       FCheckSum := Value;
  2032.       DoChange;
  2033.    end;
  2034. end;
  2035.  
  2036. procedure TfrBarcode.SetHeight(const Value: integer);
  2037. begin
  2038.    if Value <> FHeight then
  2039.    begin
  2040.       FHeight := Value;
  2041.       DoChange;
  2042.    end;
  2043. end;
  2044.  
  2045. function TfrBarcode.GetCanvasHeight: Integer;
  2046. var
  2047.   alpha :Extended;
  2048. begin
  2049.   alpha := FAngle/180.0*pi;
  2050.   Result := Round(abs(sin(alpha))*Self.Width + abs(cos(alpha))*Self.Height + 0.5); //.5 rounds up always
  2051. end;
  2052.  
  2053. function TfrBarcode.GetCanvasWidth: Integer;
  2054. var
  2055.   alpha :Extended;
  2056. begin
  2057.   alpha := FAngle/180.0*pi;
  2058.   Result := Round(abs(cos(alpha))*Self.Width + abs(sin(alpha))*Self.Height + 0.5); //.5 rounds up always
  2059. end;
  2060.  
  2061.  
  2062.  
  2063.  
  2064. end.