/components/lazreport/source/barcode.pas

   1unit Barcode;
   2
   3{
   4Barcode Component
   5Version 1.5 (23 Apr 1999)
   6Copyright 1998-99 Andreas Schmidt and friends
   7
   8Freeware
   9
  10for use with Delphi 2/3/4
  11
  12
  13this component is for private use only !
  14i'am not responsible for wrong barcodes
  15
  16bug-reports, enhancements:
  17mailto:shmia@bizerba.de or a_j_schmidt@rocketmail.com
  18
  19get latest version from
  20http://members.tripod.de/AJSchmidt/index.html
  21
  22
  23thanx to Nikolay Simeonov, Wolfgang Koranda, Norbert Waas,
  24Richard Hugues and Olivier Guilbaud.
  25
  26
  27
  28Diese Komponente darf nur in privaten Projekten verwendet werden.
  29Die Weitergabe von veränderte Dateien ist nicht zulässig.
  30Für die Korrektheit der erzeugten Barcodes kann keine Garantie
  31übernommen werden.
  32Anregungen, Bug-Reports, Danksagungen an:
  33mailto:shmia@bizerba.de
  34
  35
  36
  37History:
  38----------------------------------------------------------------------
  39Version 1.0:
  40- initial release
  41Version 1.1:
  42- more comments
  43- changed function Code_93Extended (now correct ?)
  44Version 1.2:
  45- Bugs (found by Nikolay Simeonov) removed
  46Version 1.3:
  47- EAN8/EAN13 added by Wolfgang Koranda (wkoranda@csi.com)
  48Version 1.4:
  49- Bug (found by Norbert Waas) removed
  50  Component must save the Canvas-properties Font,Pen and Brush
  51Version 1.5:
  52- Bug (found by Richard Hugues) removed
  53  Last line of barcode was 1 Pixel too wide
  54Version 1.6:
  55- new read-only property 'Width'
  56
  57
  58
  59Todo (missing features)
  60-----------------------
  61- Wrapper Class for Quick Reports
  62
  63
  64
  65}
  66
  67
  68interface
  69
  70{$I lr_vers.inc}
  71
  72uses
  73  SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
  74
  75type
  76  TBarcodeType = (bcCode_2_5_interleaved,
  77    bcCode_2_5_industrial,
  78    bcCode_2_5_matrix,
  79    bcCode39,
  80    bcCode39Extended,
  81    bcCode128A,
  82    bcCode128B,
  83    bcCode128C,
  84    bcCode93,
  85    bcCode93Extended,
  86    bcCodeMSI,
  87    bcCodePostNet,
  88    bcCodeCodabar,
  89    bcCodeEAN8,
  90    bcCodeEAN13
  91    );
  92
  93
  94  TBarLineType = (white, black, black_half);  // for internal use only
  95  // black_half means a black line with 2/5 height (used for PostNet)
  96
  97
  98  { TBarcode }
  99
 100  TBarcode = class(TComponent)
 101  private
 102    { Private-Deklarationen }
 103    FHeight: integer;
 104    FText: string;
 105    FTop: integer;
 106    FLeft: integer;
 107    FModul: integer;
 108    FRatio: double;
 109    FTyp: TBarcodeType;
 110    FCheckSum: boolean;
 111    FShowText: boolean;
 112    FAngle: double;
 113    FCodetext: string;
 114
 115    modules: array[0..3] of shortint;
 116
 117
 118    procedure OneBarProps(code: char; out aWidth: integer; out lt: TBarLineType);
 119
 120    procedure DoLines(Data: string; Canvas: TCanvas);
 121
 122    function Code_2_5_interleaved: string;
 123    function Code_2_5_industrial: string;
 124    function Code_2_5_matrix: string;
 125    function Code_39: string;
 126    function Code_39Extended: string;
 127    function Code_128: string;
 128    function Code_93: string;
 129    function Code_93Extended: string;
 130    function Code_MSI: string;
 131    function Code_PostNet: string;
 132    function Code_Codabar: string;
 133    function Code_EAN8: string;
 134    function Code_EAN13: string;
 135
 136    function GetTypText: string;
 137    procedure MakeModules;
 138
 139    procedure SetModul(v: integer);
 140
 141    function GetWidth: integer;
 142    procedure SetText(AValue: string);
 143    function CleanEANValue(const AValue: string; const ASize:Byte): string;
 144
 145  protected
 146    { Protected-Deklarationen }
 147    function MakeData: string;
 148
 149  public
 150    { Public-Deklarationen }
 151    constructor Create(aOwner: TComponent); override;
 152    procedure DrawBarcode(Canvas: TCanvas);
 153    procedure DrawText(Canvas: TCanvas);
 154    function BarcodeTypeChecked(AType: TBarcodeType): boolean;
 155
 156    property CodeText: string read FCodetext write FCodeText;
 157  published
 158    { Published-Deklarationen }
 159    // Height of Barcode (Pixel)
 160    property Height: integer read FHeight write FHeight;
 161    property Text: string read FText write SetText;
 162    property Top: integer read FTop write FTop;
 163    property Left: integer read FLeft write FLeft;
 164    // Width of the smallest line in a Barcode
 165    property Modul: integer read FModul write SetModul;
 166    property Ratio: double read FRatio write FRatio;
 167    property Typ: TBarcodeType read FTyp write FTyp default bcCode_2_5_interleaved;
 168    // build CheckSum ?
 169    property Checksum: boolean read FCheckSum write FCheckSum default False;
 170    // 0 - 360 degree
 171    property Angle: double read FAngle write FAngle;
 172
 173    property ShowText: boolean read FShowText write FShowText default False;
 174    property Width: integer read GetWidth;
 175  end;
 176
 177// procedure Register; // Removed by TZ
 178
 179implementation
 180
 181
 182{
 183  converts a string from '321' to the internal representation '715'
 184  i need this function because some pattern tables have a different
 185  format :
 186
 187  '00111'
 188  converts to '05161'
 189}
 190function Convert(s: string): string;
 191var
 192  i, v: integer;
 193  t: string;
 194begin
 195  t := '';
 196  for i := 1 to Length(s) do
 197  begin
 198    v := Ord(s[i]) - 1;
 199
 200    if odd(i) then
 201      Inc(v, 5);
 202    t := t + Chr(v);
 203  end;
 204  Convert := t;
 205end;
 206
 207(*
 208 * Berechne die Quersumme aus einer Zahl x
 209 * z.B.: Quersumme von 1234 ist 10
 210 *)
 211function quersumme(x: integer): integer;
 212var
 213  sum: integer;
 214begin
 215  sum := 0;
 216
 217  while x > 0 do
 218  begin
 219    sum := sum + (x mod 10);
 220    x := x div 10;
 221  end;
 222  Result := sum;
 223end;
 224
 225
 226{
 227  Rotate a Point by Angle 'alpha'
 228}
 229function Rotate2D(p: TPoint; alpha: double): TPoint;
 230var
 231  sinus, cosinus: extended;
 232begin
 233  sinus := sin(alpha);
 234  cosinus := cos(alpha);
 235  Result.x := Round(p.x * cosinus + p.y * sinus);
 236  Result.y := Round(-p.x * sinus + p.y * cosinus);
 237end;
 238
 239{
 240  Move Point a by Vector b
 241}
 242function Translate2D(a, b: TPoint): TPoint;
 243begin
 244  Result.x := a.x + b.x;
 245  Result.y := a.y + b.y;
 246end;
 247
 248constructor TBarcode.Create(aOwner: TComponent);
 249begin
 250  inherited Create(aOwner);
 251
 252  FAngle := 0.0;
 253  FRatio := 2.0;
 254  FModul := 1;
 255  FTyp := bcCodeEAN13;
 256  FCheckSum := False;
 257  FShowText := False;
 258end;
 259
 260function TBarcode.GetTypText: string;
 261const
 262  bcNames: array[bcCode_2_5_interleaved..bcCodeEAN13] of string =
 263    (
 264    ('2_5_interleaved'),
 265    ('2_5_industrial'),
 266    ('2_5_matrix'),
 267    ('Code39'),
 268    ('Code39 Extended'),
 269    ('Code128A'),
 270    ('Code128B'),
 271    ('Code128C'),
 272    ('Code93'),
 273    ('Code93 Extended'),
 274    ('MSI'),
 275    ('PostNet'),
 276    ('Codebar'),
 277    ('EAN8'),
 278    ('EAN13')
 279    );
 280begin
 281  Result := bcNames[FTyp];
 282end;
 283
 284// set Modul Width
 285procedure TBarcode.SetModul(v: integer);
 286begin
 287  if (v >= 1) and (v < 50) then
 288    FModul := v;
 289end;
 290
 291{
 292calculate the width and the linetype of a sigle bar
 293
 294
 295  Code   Line-Color      Width               Height
 296------------------------------------------------------------------
 297        '0'   white           100%                full
 298        '1'   white           100%*Ratio          full
 299        '2'   white           150%*Ratio          full
 300        '3'   white           200%*Ratio          full
 301        '5'   black           100%                full
 302        '6'   black           100%*Ratio          full
 303        '7'   black           150%*Ratio          full
 304        '8'   black           200%*Ratio          full
 305        'A'   black           100%                2/5  (used for PostNet)
 306        'B'   black           100%*Ratio          2/5  (used for PostNet)
 307        'C'   black           150%*Ratio          2/5  (used for PostNet)
 308        'D'   black           200%*Ratio          2/5  (used for PostNet)
 309}
 310procedure TBarcode.OneBarProps(code: char; out aWidth: integer; out lt: TBarLineType);
 311begin
 312  case code of
 313    '0':
 314    begin
 315      aWidth := modules[0];
 316      lt := white;
 317    end;
 318    '1':
 319    begin
 320      aWidth := modules[1];
 321      lt := white;
 322    end;
 323    '2':
 324    begin
 325      aWidth := modules[2];
 326      lt := white;
 327    end;
 328    '3':
 329    begin
 330      aWidth := modules[3];
 331      lt := white;
 332    end;
 333
 334
 335    '5':
 336    begin
 337      aWidth := modules[0];
 338      lt := black;
 339    end;
 340    '6':
 341    begin
 342      aWidth := modules[1];
 343      lt := black;
 344    end;
 345    '7':
 346    begin
 347      aWidth := modules[2];
 348      lt := black;
 349    end;
 350    '8':
 351    begin
 352      aWidth := modules[3];
 353      lt := black;
 354    end;
 355
 356    'A':
 357    begin
 358      aWidth := modules[0];
 359      lt := black_half;
 360    end;
 361    'B':
 362    begin
 363      aWidth := modules[1];
 364      lt := black_half;
 365    end;
 366    'C':
 367    begin
 368      aWidth := modules[2];
 369      lt := black_half;
 370    end;
 371    'D':
 372    begin
 373      aWidth := modules[3];
 374      lt := black_half;
 375    end;
 376    else
 377    begin
 378      // something went wrong  :-(
 379      // mistyped pattern table
 380      raise Exception.CreateFmt('%s: internal Error', [self.ClassName]);
 381    end;
 382  end;
 383end;
 384
 385
 386function TBarcode.MakeData: string;
 387begin
 388  // calculate the with of the different lines (modules)
 389  MakeModules;
 390
 391  // get the pattern of the barcode
 392  case Typ of
 393    bcCode_2_5_interleaved:
 394      Result := Code_2_5_interleaved;
 395    bcCode_2_5_industrial:
 396      Result := Code_2_5_industrial;
 397    bcCode_2_5_matrix:
 398      Result := Code_2_5_matrix;
 399    bcCode39:
 400      Result := Code_39;
 401    bcCode39Extended:
 402      Result := Code_39Extended;
 403    bcCode128A,
 404    bcCode128B,
 405    bcCode128C:
 406      Result := Code_128;
 407    bcCode93:
 408      Result := Code_93;
 409    bcCode93Extended:
 410      Result := Code_93Extended;
 411    bcCodeMSI:
 412      Result := Code_MSI;
 413    bcCodePostNet:
 414      Result := Code_PostNet;
 415    bcCodeCodabar:
 416      Result := Code_Codabar;
 417    bcCodeEAN8:
 418      Result := Code_EAN8;
 419    bcCodeEAN13:
 420      Result := Code_EAN13;
 421    else
 422      raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]);
 423  end;
 424
 425  //Showmessage(Format('Data <%s>', [Result]));
 426end;
 427
 428
 429function TBarcode.GetWidth: integer;
 430var
 431  Data: string;
 432  i: integer;
 433  w: integer;
 434  lt: TBarLineType;
 435begin
 436  Result := 0;
 437
 438  // get barcode pattern
 439  Data := MakeData;
 440
 441  for i := 1 to Length(Data) do  // examine the pattern string
 442  begin
 443    OneBarProps(Data[i], w, lt);
 444    Inc(Result, w);
 445  end;
 446end;
 447
 448procedure TBarcode.SetText(AValue: string);
 449begin
 450  if FText=AValue then Exit;
 451  FText:=AValue;
 452  FCodeText:=AValue;
 453end;
 454
 455
 456////////////////////////////// EAN /////////////////////////////////////////
 457
 458function getEAN(Nr: string): string;
 459var
 460  i, fak, sum: integer;
 461  tmp: string;
 462begin
 463  sum := 0;
 464  tmp := copy(nr, 1, Length(Nr) - 1);
 465  fak := Length(tmp);
 466  for i := 1 to length(tmp) do
 467  begin
 468    if (fak mod 2) = 0 then
 469      sum := sum + (StrToInt(tmp[i]) * 1)
 470    else
 471      sum := sum + (StrToInt(tmp[i]) * 3);
 472    Dec(fak);
 473  end;
 474  if (sum mod 10) = 0 then
 475    Result := tmp + '0'
 476  else
 477    Result := tmp + IntToStr(10 - (sum mod 10));
 478end;
 479
 480////////////////////////////// EAN8 /////////////////////////////////////////
 481
 482// Pattern for Barcode EAN Zeichensatz A
 483//       L1   S1   L2   S2
 484const
 485  tabelle_EAN_A: array['0'..'9', 1..4] of char =
 486    (
 487    ('2', '6', '0', '5'),    // 0
 488    ('1', '6', '1', '5'),    // 1
 489    ('1', '5', '1', '6'),    // 2
 490    ('0', '8', '0', '5'),    // 3
 491    ('0', '5', '2', '6'),    // 4
 492    ('0', '6', '2', '5'),    // 5
 493    ('0', '5', '0', '8'),    // 6
 494    ('0', '7', '0', '6'),    // 7
 495    ('0', '6', '0', '7'),    // 8
 496    ('2', '5', '0', '6')     // 9
 497    );
 498
 499// Pattern for Barcode EAN Zeichensatz C
 500//       S1   L1   S2   L2
 501const
 502  tabelle_EAN_C: array['0'..'9', 1..4] of char =
 503    (
 504    ('7', '1', '5', '0'),    // 0
 505    ('6', '1', '6', '0'),    // 1
 506    ('6', '0', '6', '1'),    // 2
 507    ('5', '3', '5', '0'),    // 3
 508    ('5', '0', '7', '1'),    // 4
 509    ('5', '1', '7', '0'),    // 5
 510    ('5', '0', '5', '3'),    // 6
 511    ('5', '2', '5', '1'),    // 7
 512    ('5', '1', '5', '2'),    // 8
 513    ('7', '0', '5', '1')     // 9
 514    );
 515
 516
 517function TBarcode.Code_EAN8: string;
 518var
 519  i, j: integer;
 520begin
 521
 522  FCodeText := CleanEANValue(FText, 8);
 523
 524  Result := '505';   // Startcode
 525
 526  for i := 1 to 4 do
 527    for j := 1 to 4 do
 528    begin
 529      Result := Result + tabelle_EAN_A[FCodeText[i], j];
 530    end;
 531
 532  Result := Result + '05050';   // Trennzeichen
 533
 534  for i := 5 to 8 do
 535    for j := 1 to 4 do
 536    begin
 537      Result := Result + tabelle_EAN_C[FCodeText[i], j];
 538    end;
 539
 540  Result := Result + '505';   // Stopcode
 541end;
 542
 543////////////////////////////// EAN13 ///////////////////////////////////////
 544
 545// Pattern for Barcode EAN Zeichensatz B
 546//       L1   S1   L2   S2
 547const
 548  tabelle_EAN_B: array['0'..'9', 1..4] of char =
 549    (
 550    ('0', '5', '1', '7'),    // 0
 551    ('0', '6', '1', '6'),    // 1
 552    ('1', '6', '0', '6'),    // 2
 553    ('0', '5', '3', '5'),    // 3
 554    ('1', '7', '0', '5'),    // 4
 555    ('0', '7', '1', '5'),    // 5
 556    ('3', '5', '0', '5'),    // 6
 557    ('1', '5', '2', '5'),    // 7
 558    ('2', '5', '1', '5'),    // 8
 559    ('1', '5', '0', '7')     // 9
 560    );
 561
 562// Zuordung der Paraitaetsfolgen für EAN13
 563const
 564  tabelle_ParityEAN13: array[0..9, 1..6] of char =
 565    (
 566    ('A', 'A', 'A', 'A', 'A', 'A'),    // 0
 567    ('A', 'A', 'B', 'A', 'B', 'B'),    // 1
 568    ('A', 'A', 'B', 'B', 'A', 'B'),    // 2
 569    ('A', 'A', 'B', 'B', 'B', 'A'),    // 3
 570    ('A', 'B', 'A', 'A', 'B', 'B'),    // 4
 571    ('A', 'B', 'B', 'A', 'A', 'B'),    // 5
 572    ('A', 'B', 'B', 'B', 'A', 'A'),    // 6
 573    ('A', 'B', 'A', 'B', 'A', 'B'),    // 7
 574    ('A', 'B', 'A', 'B', 'B', 'A'),    // 8
 575    ('A', 'B', 'B', 'A', 'B', 'A')     // 9
 576    );
 577
 578function TBarcode.Code_EAN13: string;
 579var
 580  i, j, LK: integer;
 581  tmp: string;
 582begin
 583
 584  FCodeText := CleanEanValue(FText, 13);
 585
 586  LK := StrToInt(FCodeText[1]);
 587  tmp := copy(FCodeText, 2, 12);
 588
 589  Result := '505';   // Startcode
 590
 591  for i := 1 to 6 do
 592  begin
 593    case tabelle_ParityEAN13[LK, i] of
 594      'A':
 595        for j := 1 to 4 do
 596          Result := Result + tabelle_EAN_A[tmp[i], j];
 597      'B':
 598        for j := 1 to 4 do
 599          Result := Result + tabelle_EAN_B[tmp[i], j];
 600      'C':
 601        for j := 1 to 4 do
 602          Result := Result + tabelle_EAN_C[tmp[i], j];
 603    end;
 604  end;
 605
 606  Result := Result + '05050';   // Trennzeichen
 607
 608  for i := 7 to 12 do
 609    for j := 1 to 4 do
 610    begin
 611      Result := Result + tabelle_EAN_C[tmp[i], j];
 612    end;
 613
 614  Result := Result + '505';   // Stopcode
 615end;
 616
 617// Pattern for Barcode 2 of 5
 618const
 619  tabelle_2_5: array['0'..'9', 1..5] of char =
 620    (
 621    ('0', '0', '1', '1', '0'),    // 0
 622    ('1', '0', '0', '0', '1'),    // 1
 623    ('0', '1', '0', '0', '1'),    // 2
 624    ('1', '1', '0', '0', '0'),    // 3
 625    ('0', '0', '1', '0', '1'),    // 4
 626    ('1', '0', '1', '0', '0'),    // 5
 627    ('0', '1', '1', '0', '0'),    // 6
 628    ('0', '0', '0', '1', '1'),    // 7
 629    ('1', '0', '0', '1', '0'),    // 8
 630    ('0', '1', '0', '1', '0')     // 9
 631    );
 632
 633function TBarcode.Code_2_5_interleaved: string;
 634var
 635  i, j: integer;
 636  c: char;
 637
 638begin
 639  Result := '5050';   // Startcode
 640
 641  for i := 1 to Length(FText) div 2 do
 642  begin
 643    for j := 1 to 5 do
 644    begin
 645      if tabelle_2_5[FText[i * 2 - 1], j] = '1' then
 646        c := '6'
 647      else
 648        c := '5';
 649      Result := Result + c;
 650      if tabelle_2_5[FText[i * 2], j] = '1' then
 651        c := '1'
 652      else
 653        c := '0';
 654      Result := Result + c;
 655    end;
 656  end;
 657
 658  Result := Result + '605';    // Stopcode
 659end;
 660
 661
 662function TBarcode.Code_2_5_industrial: string;
 663var
 664  i, j: integer;
 665begin
 666  Result := '606050';   // Startcode
 667
 668  for i := 1 to Length(FText) do
 669  begin
 670    for j := 1 to 5 do
 671    begin
 672      if tabelle_2_5[FText[i], j] = '1' then
 673        Result := Result + '60'
 674      else
 675        Result := Result + '50';
 676    end;
 677  end;
 678
 679  Result := Result + '605060';   // Stopcode
 680end;
 681
 682function TBarcode.Code_2_5_matrix: string;
 683var
 684  i, j: integer;
 685  c: char;
 686begin
 687  Result := '705050';   // Startcode
 688
 689  for i := 1 to Length(FText) do
 690  begin
 691    for j := 1 to 5 do
 692    begin
 693      if tabelle_2_5[FText[i], j] = '1' then
 694        c := '1'
 695      else
 696        c := '0';
 697
 698      // Falls i ungerade ist dann mache Lücke zu Strich
 699      if odd(j) then
 700        c := chr(Ord(c) + 5);
 701      Result := Result + c;
 702    end;
 703    Result := Result + '0';   // Lücke zwischen den Zeichen
 704  end;
 705
 706  Result := Result + '70505';   // Stopcode
 707end;
 708
 709
 710function TBarcode.Code_39: string;
 711
 712type
 713  TCode39 = record
 714    c: char;
 715    Data: array[0..9] of char;
 716    chk: shortint;
 717  end;
 718
 719const
 720  tabelle_39: array[0..43] of TCode39 = (
 721    (c: '0'; Data: '505160605'; chk: 0),
 722    (c: '1'; Data: '605150506'; chk: 1),
 723    (c: '2'; Data: '506150506'; chk: 2),
 724    (c: '3'; Data: '606150505'; chk: 3),
 725    (c: '4'; Data: '505160506'; chk: 4),
 726    (c: '5'; Data: '605160505'; chk: 5),
 727    (c: '6'; Data: '506160505'; chk: 6),
 728    (c: '7'; Data: '505150606'; chk: 7),
 729    (c: '8'; Data: '605150605'; chk: 8),
 730    (c: '9'; Data: '506150605'; chk: 9),
 731    (c: 'A'; Data: '605051506'; chk: 10),
 732    (c: 'B'; Data: '506051506'; chk: 11),
 733    (c: 'C'; Data: '606051505'; chk: 12),
 734    (c: 'D'; Data: '505061506'; chk: 13),
 735    (c: 'E'; Data: '605061505'; chk: 14),
 736    (c: 'F'; Data: '506061505'; chk: 15),
 737    (c: 'G'; Data: '505051606'; chk: 16),
 738    (c: 'H'; Data: '605051605'; chk: 17),
 739    (c: 'I'; Data: '506051600'; chk: 18),
 740    (c: 'J'; Data: '505061605'; chk: 19),
 741    (c: 'K'; Data: '605050516'; chk: 20),
 742    (c: 'L'; Data: '506050516'; chk: 21),
 743    (c: 'M'; Data: '606050515'; chk: 22),
 744    (c: 'N'; Data: '505060516'; chk: 23),
 745    (c: 'O'; Data: '605060515'; chk: 24),
 746    (c: 'P'; Data: '506060515'; chk: 25),
 747    (c: 'Q'; Data: '505050616'; chk: 26),
 748    (c: 'R'; Data: '605050615'; chk: 27),
 749    (c: 'S'; Data: '506050615'; chk: 28),
 750    (c: 'T'; Data: '505060615'; chk: 29),
 751    (c: 'U'; Data: '615050506'; chk: 30),
 752    (c: 'V'; Data: '516050506'; chk: 31),
 753    (c: 'W'; Data: '616050505'; chk: 32),
 754    (c: 'X'; Data: '515060506'; chk: 33),
 755    (c: 'Y'; Data: '615060505'; chk: 34),
 756    (c: 'Z'; Data: '516060505'; chk: 35),
 757    (c: '-'; Data: '515050606'; chk: 36),
 758    (c: '.'; Data: '615050605'; chk: 37),
 759    (c: ' '; Data: '516050605'; chk: 38),
 760    (c: '*'; Data: '515060605'; chk: 0),
 761    (c: '$'; Data: '515151505'; chk: 39),
 762    (c: '/'; Data: '515150515'; chk: 40),
 763    (c: '+'; Data: '515051515'; chk: 41),
 764    (c: '%'; Data: '505151515'; chk: 42)
 765    );
 766
 767
 768  function FindIdx(z: char): integer;
 769  var
 770    i: integer;
 771  begin
 772    Result := -1;
 773    for i := 0 to High(tabelle_39) do
 774    begin
 775      if z = tabelle_39[i].c then
 776      begin
 777        Result := i;
 778        Break;
 779      end;
 780    end;
 781  end;
 782
 783var
 784  i, idx: integer;
 785  vChecksum: integer;
 786
 787begin
 788  vChecksum := 0;
 789  // Startcode
 790  Result := tabelle_39[FindIdx('*')].Data + '0';
 791
 792  for i := 1 to Length(FText) do
 793  begin
 794    idx := FindIdx(FText[i]);
 795    if idx < 0 then
 796      continue;
 797    Result := Result + tabelle_39[idx].Data + '0';
 798    Inc(vChecksum, tabelle_39[idx].chk);
 799  end;
 800
 801  // Calculate Checksum Data
 802  if FCheckSum then
 803  begin
 804    vChecksum := vChecksum mod 43;
 805    for i := 0 to High(tabelle_39) do
 806      if vChecksum = tabelle_39[i].chk then
 807      begin
 808        Result := Result + tabelle_39[i].Data + '0';
 809        exit;
 810      end;
 811  end;
 812
 813  // Stopcode
 814  Result := Result + tabelle_39[FindIdx('*')].Data;
 815end;
 816
 817function TBarcode.Code_39Extended: string;
 818
 819const
 820  code39x: array[0..127] of string[2] =
 821    (
 822    ('%U'), ('$A'), ('$B'), ('$C'), ('$D'), ('$E'), ('$F'), ('$G'),
 823    ('$H'), ('$I'), ('$J'), ('$K'), ('$L'), ('$M'), ('$N'), ('$O'),
 824    ('$P'), ('$Q'), ('$R'), ('$S'), ('$T'), ('$U'), ('$V'), ('$W'),
 825    ('$X'), ('$Y'), ('$Z'), ('%A'), ('%B'), ('%C'), ('%D'), ('%E'),
 826    (' '),  ('/A'), ('/B'), ('/C'), ('/D'), ('/E'), ('/F'), ('/G'),
 827    ('/H'), ('/I'), ('/J'), ('/K'), ('/L'), ('/M'), ('/N'), ('/O'),
 828    ('0'),  ('1'),  ('2'),  ('3'),  ('4'),  ('5'),  ('6'),  ('7'),
 829    ('8'),  ('9'),  ('/Z'), ('%F'), ('%G'), ('%H'), ('%I'), ('%J'),
 830    ('%V'), ('A'),  ('B'),  ('C'),  ('D'),  ('E'),  ('F'),  ('G'),
 831    ('H'),  ('I'),  ('J'),  ('K'),  ('L'),  ('M'),  ('N'),  ('O'),
 832    ('P'),  ('Q'),  ('R'),  ('S'),  ('T'),  ('U'),  ('V'),  ('W'),
 833    ('X'),  ('Y'),  ('Z'),  ('%K'), ('%L'), ('%M'), ('%N'), ('%O'),
 834    ('%W'), ('+A'), ('+B'), ('+C'), ('+D'), ('+E'), ('+F'), ('+G'),
 835    ('+H'), ('+I'), ('+J'), ('+K'), ('+L'), ('+M'), ('+N'), ('+O'),
 836    ('+P'), ('+Q'), ('+R'), ('+S'), ('+T'), ('+U'), ('+V'), ('+W'),
 837    ('+X'), ('+Y'), ('+Z'), ('%P'), ('%Q'), ('%R'), ('%S'), ('%T')
 838    );
 839
 840var
 841  save: string;
 842  i: integer;
 843begin
 844  save := FText;
 845  FText := '';
 846
 847  for i := 1 to Length(save) do
 848  begin
 849    if Ord(save[i]) <= 127 then
 850      FText := FText + code39x[Ord(save[i])];
 851  end;
 852  Result := Code_39;
 853  FText := save;
 854end;
 855
 856
 857{
 858Code 128
 859}
 860function TBarcode.Code_128: string;
 861type
 862  TCode128 = record
 863    a, b: char;
 864    c: string[2];
 865    Data: string[6];
 866  end;
 867
 868const
 869  tabelle_128: array[0..102] of TCode128 = (
 870    (a: ' '; b: ' '; c: '00'; Data: '212222'; ),
 871    (a: '!'; b: '!'; c: '01'; Data: '222122'; ),
 872    (a: '"'; b: '"'; c: '02'; Data: '222221'; ),
 873    (a: '#'; b: '#'; c: '03'; Data: '121223'; ),
 874    (a: '$'; b: '$'; c: '04'; Data: '121322'; ),
 875    (a: '%'; b: '%'; c: '05'; Data: '131222'; ),
 876    (a: '&'; b: '&'; c: '06'; Data: '122213'; ),
 877    (a: ''''; b: ''''; c: '07'; Data: '122312'; ),
 878    (a: '('; b: '('; c: '08'; Data: '132212'; ),
 879    (a: ')'; b: ')'; c: '09'; Data: '221213'; ),
 880    (a: '*'; b: '*'; c: '10'; Data: '221312'; ),
 881    (a: '+'; b: '+'; c: '11'; Data: '231212'; ),
 882    (a: ','; b: ','; c: '12'; Data: '112232'; ),
 883    (a: '-'; b: '-'; c: '13'; Data: '122132'; ),
 884    (a: '.'; b: '.'; c: '14'; Data: '122231'; ),
 885    (a: '/'; b: '/'; c: '15'; Data: '113222'; ),
 886    (a: '0'; b: '0'; c: '16'; Data: '123122'; ),
 887    (a: '1'; b: '1'; c: '17'; Data: '123221'; ),
 888    (a: '2'; b: '2'; c: '18'; Data: '223211'; ),
 889    (a: '3'; b: '3'; c: '19'; Data: '221132'; ),
 890    (a: '4'; b: '4'; c: '20'; Data: '221231'; ),
 891    (a: '5'; b: '5'; c: '21'; Data: '213212'; ),
 892    (a: '6'; b: '6'; c: '22'; Data: '223112'; ),
 893    (a: '7'; b: '7'; c: '23'; Data: '312131'; ),
 894    (a: '8'; b: '8'; c: '24'; Data: '311222'; ),
 895    (a: '9'; b: '9'; c: '25'; Data: '321122'; ),
 896    (a: ':'; b: ':'; c: '26'; Data: '321221'; ),
 897    (a: ';'; b: ';'; c: '27'; Data: '312212'; ),
 898    (a: '<'; b: '<'; c: '28'; Data: '322112'; ),
 899    (a: '='; b: '='; c: '29'; Data: '322211'; ),
 900    (a: '>'; b: '>'; c: '30'; Data: '212123'; ),
 901    (a: '?'; b: '?'; c: '31'; Data: '212321'; ),
 902    (a: '@'; b: '@'; c: '32'; Data: '232121'; ),
 903    (a: 'A'; b: 'A'; c: '33'; Data: '111323'; ),
 904    (a: 'B'; b: 'B'; c: '34'; Data: '131123'; ),
 905    (a: 'C'; b: 'C'; c: '35'; Data: '131321'; ),
 906    (a: 'D'; b: 'D'; c: '36'; Data: '112313'; ),
 907    (a: 'E'; b: 'E'; c: '37'; Data: '132113'; ),
 908    (a: 'F'; b: 'F'; c: '38'; Data: '132311'; ),
 909    (a: 'G'; b: 'G'; c: '39'; Data: '211313'; ),
 910    (a: 'H'; b: 'H'; c: '40'; Data: '231113'; ),
 911    (a: 'I'; b: 'I'; c: '41'; Data: '231311'; ),
 912    (a: 'J'; b: 'J'; c: '42'; Data: '112133'; ),
 913    (a: 'K'; b: 'K'; c: '43'; Data: '112331'; ),
 914    (a: 'L'; b: 'L'; c: '44'; Data: '132131'; ),
 915    (a: 'M'; b: 'M'; c: '45'; Data: '113123'; ),
 916    (a: 'N'; b: 'N'; c: '46'; Data: '113321'; ),
 917    (a: 'O'; b: 'O'; c: '47'; Data: '133121'; ),
 918    (a: 'P'; b: 'P'; c: '48'; Data: '313121'; ),
 919    (a: 'Q'; b: 'Q'; c: '49'; Data: '211331'; ),
 920    (a: 'R'; b: 'R'; c: '50'; Data: '231131'; ),
 921    (a: 'S'; b: 'S'; c: '51'; Data: '213113'; ),
 922    (a: 'T'; b: 'T'; c: '52'; Data: '213311'; ),
 923    (a: 'U'; b: 'U'; c: '53'; Data: '213131'; ),
 924    (a: 'V'; b: 'V'; c: '54'; Data: '311123'; ),
 925    (a: 'W'; b: 'W'; c: '55'; Data: '311321'; ),
 926    (a: 'X'; b: 'X'; c: '56'; Data: '331121'; ),
 927    (a: 'Y'; b: 'Y'; c: '57'; Data: '312113'; ),
 928    (a: 'Z'; b: 'Z'; c: '58'; Data: '312311'; ),
 929    (a: '['; b: '['; c: '59'; Data: '332111'; ),
 930    (a: '\'; b: '\'; c: '60'; Data: '314111'; ),
 931    (a: ']'; b: ']'; c: '61'; Data: '221411'; ),
 932    (a: '^'; b: '^'; c: '62'; Data: '431111'; ),
 933    (a: '_'; b: '_'; c: '63'; Data: '111224'; ),
 934    (a: ' '; b: '`'; c: '64'; Data: '111422'; ),
 935    (a: ' '; b: 'a'; c: '65'; Data: '121124'; ),
 936    (a: ' '; b: 'b'; c: '66'; Data: '121421'; ),
 937    (a: ' '; b: 'c'; c: '67'; Data: '141122'; ),
 938    (a: ' '; b: 'd'; c: '68'; Data: '141221'; ),
 939    (a: ' '; b: 'e'; c: '69'; Data: '112214'; ),
 940    (a: ' '; b: 'f'; c: '70'; Data: '112412'; ),
 941    (a: ' '; b: 'g'; c: '71'; Data: '122114'; ),
 942    (a: ' '; b: 'h'; c: '72'; Data: '122411'; ),
 943    (a: ' '; b: 'i'; c: '73'; Data: '142112'; ),
 944    (a: ' '; b: 'j'; c: '74'; Data: '142211'; ),
 945    (a: ' '; b: 'k'; c: '75'; Data: '241211'; ),
 946    (a: ' '; b: 'l'; c: '76'; Data: '221114'; ),
 947    (a: ' '; b: 'm'; c: '77'; Data: '413111'; ),
 948    (a: ' '; b: 'n'; c: '78'; Data: '241112'; ),
 949    (a: ' '; b: 'o'; c: '79'; Data: '134111'; ),
 950    (a: ' '; b: 'p'; c: '80'; Data: '111242'; ),
 951    (a: ' '; b: 'q'; c: '81'; Data: '121142'; ),
 952    (a: ' '; b: 'r'; c: '82'; Data: '121241'; ),
 953    (a: ' '; b: 's'; c: '83'; Data: '114212'; ),
 954    (a: ' '; b: 't'; c: '84'; Data: '124112'; ),
 955    (a: ' '; b: 'u'; c: '85'; Data: '124211'; ),
 956    (a: ' '; b: 'v'; c: '86'; Data: '411212'; ),
 957    (a: ' '; b: 'w'; c: '87'; Data: '421112'; ),
 958    (a: ' '; b: 'x'; c: '88'; Data: '421211'; ),
 959    (a: ' '; b: 'y'; c: '89'; Data: '212141'; ),
 960    (a: ' '; b: 'z'; c: '90'; Data: '214121'; ),
 961    (a: ' '; b: '{'; c: '91'; Data: '412121'; ),
 962    (a: ' '; b: '|'; c: '92'; Data: '111143'; ),
 963    (a: ' '; b: '}'; c: '93'; Data: '111341'; ),
 964    (a: ' '; b: '~'; c: '94'; Data: '131141'; ),
 965    (a: ' '; b: ' '; c: '95'; Data: '114113'; ),
 966    (a: ' '; b: ' '; c: '96'; Data: '114311'; ),
 967    (a: ' '; b: ' '; c: '97'; Data: '411113'; ),
 968    (a: ' '; b: ' '; c: '98'; Data: '411311'; ),
 969    (a: ' '; b: ' '; c: '99'; Data: '113141'; ),
 970    (a: ' '; b: ' '; c: '  '; Data: '114131'; ),
 971    (a: ' '; b: ' '; c: '  '; Data: '311141'; ),
 972    (a: ' '; b: ' '; c: '  '; Data: '411131'; )
 973    );
 974
 975  StartA = '211412';
 976  StartB = '211214';
 977  StartC = '211232';
 978  Stop = '2331112';
 979
 980
 981  // find Code 128 Codeset A or B
 982  function Find_Code128AB(c: char): integer;
 983  var
 984    i: integer;
 985    v: char;
 986  begin
 987    for i := 0 to High(tabelle_128) do
 988    begin
 989      if FTyp = bcCode128A then
 990        v := tabelle_128[i].a
 991      else
 992        v := tabelle_128[i].b;
 993
 994      if c = v then
 995      begin
 996        Result := i;
 997        exit;
 998      end;
 999    end;
1000    Result := -1;
1001  end;
1002
1003var
1004  i, idx: integer;
1005  startcode, tmp: string;
1006  vChecksum: integer;
1007
1008begin
1009
1010  vChecksum := 0; // Added by TZ
1011  case FTyp of
1012    bcCode128A:
1013    begin
1014      vChecksum := 103;
1015      startcode := StartA;
1016      FCodeText := FText;
1017    end;
1018    bcCode128B:
1019    begin
1020      vChecksum := 104;
1021      startcode := StartB;
1022      FCodeText := FText;
1023    end;
1024    bcCode128C:
1025    begin
1026      vChecksum := 105;
1027      startcode := StartC;
1028
1029      // make sure we have an even numeric only string
1030      FCodeText := '';
1031      for i := 1 to Length(FText) do
1032        if not (FText[i] in ['0'..'9']) then
1033          FCodeText := FCodeText + '0'
1034        else
1035          FCodeText := FCodeText + FText[i];
1036
1037      if Odd(Length(FText)) then
1038        FCodeText := '0' + FText;
1039    end;
1040  end;
1041
1042  Result := Convert(startcode);    // Startcode
1043
1044  if FTyp = bcCode128C then
1045  begin
1046    tmp := '';
1047    i := 1;
1048    while i<Length(FCodeText) do
1049    begin
1050      tmp := tmp + chr( StrToIntDef(Copy(FCodeText, i, 2), 0) );
1051      inc(i,2);
1052    end;
1053  end else
1054    tmp := FCodeText;
1055
1056  for i := 1 to Length(tmp) do
1057  begin
1058    if FTyp = bcCode128C then
1059      idx := Ord(tmp[i])
1060    else begin
1061      idx := Find_Code128AB(tmp[i]);
1062      if idx < 0 then
1063        idx := Find_Code128AB(' ');
1064    end;
1065    Result := Result + Convert(tabelle_128[idx].Data);
1066    Inc(vChecksum, idx * i);
1067  end;
1068
1069  vChecksum := vChecksum mod 103;
1070  Result := Result + Convert(tabelle_128[vChecksum].Data);
1071
1072  Result := Result + Convert(Stop);      // Stopcode
1073end;
1074
1075
1076function TBarcode.Code_93: string;
1077type
1078  TCode93 = record
1079    c: char;
1080    Data: array[0..5] of char;
1081  end;
1082
1083const
1084  tabelle_93: array[0..46] of TCode93 = (
1085    (c: '0'; Data: '131112'),
1086    (c: '1'; Data: '111213'),
1087    (c: '2'; Data: '111312'),
1088    (c: '3'; Data: '111411'),
1089    (c: '4'; Data: '121113'),
1090    (c: '5'; Data: '121212'),
1091    (c: '6'; Data: '121311'),
1092    (c: '7'; Data: '111114'),
1093    (c: '8'; Data: '131211'),
1094    (c: '9'; Data: '141111'),
1095    (c: 'A'; Data: '211113'),
1096    (c: 'B'; Data: '211212'),
1097    (c: 'C'; Data: '211311'),
1098    (c: 'D'; Data: '221112'),
1099    (c: 'E'; Data: '221211'),
1100    (c: 'F'; Data: '231111'),
1101    (c: 'G'; Data: '112113'),
1102    (c: 'H'; Data: '112212'),
1103    (c: 'I'; Data: '112311'),
1104    (c: 'J'; Data: '122112'),
1105    (c: 'K'; Data: '132111'),
1106    (c: 'L'; Data: '111123'),
1107    (c: 'M'; Data: '111222'),
1108    (c: 'N'; Data: '111321'),
1109    (c: 'O'; Data: '121122'),
1110    (c: 'P'; Data: '131121'),
1111    (c: 'Q'; Data: '212112'),
1112    (c: 'R'; Data: '212211'),
1113    (c: 'S'; Data: '211122'),
1114    (c: 'T'; Data: '211221'),
1115    (c: 'U'; Data: '221121'),
1116    (c: 'V'; Data: '222111'),
1117    (c: 'W'; Data: '112122'),
1118    (c: 'X'; Data: '112221'),
1119    (c: 'Y'; Data: '122121'),
1120    (c: 'Z'; Data: '123111'),
1121    (c: '-'; Data: '121131'),
1122    (c: '.'; Data: '311112'),
1123    (c: ' '; Data: '311211'),
1124    (c: '$'; Data: '321111'),
1125    (c: '/'; Data: '112131'),
1126    (c: '+'; Data: '113121'),
1127    (c: '%'; Data: '211131'),
1128    (c: '['; Data: '121221'),   // only used for Extended Code 93
1129    (c: ']'; Data: '312111'),   // only used for Extended Code 93
1130    (c: '{'; Data: '311121'),   // only used for Extended Code 93
1131    (c: '}'; Data: '122211')    // only used for Extended Code 93
1132    );
1133
1134
1135  // find Code 93
1136  function Find_Code93(c: char): integer;
1137  var
1138    i: integer;
1139  begin
1140    for i := 0 to High(tabelle_93) do
1141    begin
1142      if c = tabelle_93[i].c then
1143      begin
1144        Result := i;
1145        exit;
1146      end;
1147    end;
1148    Result := -1;
1149  end;
1150
1151var
1152  i, idx: integer;
1153  checkC, checkK,   // Checksums
1154  weightC, weightK: integer;
1155begin
1156  Result := Convert('111141');   // Startcode
1157
1158  for i := 1 to Length(FText) do
1159  begin
1160    idx := Find_Code93(FText[i]);
1161    if idx < 0 then
1162      raise Exception.CreateFmt('%s:Code93 bad Data <%s>', [self.ClassName, FText]);
1163    Result := Result + Convert(tabelle_93[idx].Data);
1164  end;
1165
1166  checkC := 0;
1167  checkK := 0;
1168
1169  weightC := 1;
1170  weightK := 2;
1171
1172  for i := Length(FText) downto 1 do
1173  begin
1174    idx := Find_Code93(FText[i]);
1175
1176    Inc(checkC, idx * weightC);
1177    Inc(checkK, idx * weightK);
1178
1179    Inc(weightC);
1180    if weightC > 20 then
1181      weightC := 1;
1182    Inc(weightK);
1183    if weightK > 15 then
1184      weightC := 1;
1185  end;
1186
1187  Inc(checkK, checkC);
1188
1189  checkC := checkC mod 47;
1190  checkK := checkK mod 47;
1191
1192  Result := Result + Convert(tabelle_93[checkC].Data) +
1193    Convert(tabelle_93[checkK].Data);
1194
1195  Result := Result + Convert('1111411');   // Stopcode
1196end;
1197
1198
1199function TBarcode.Code_93Extended: string;
1200const
1201  code93x: array[0..127] of string[2] =
1202    (
1203    (']U'), ('[A'), ('[B'), ('[C'), ('[D'), ('[E'), ('[F'), ('[G'),
1204    ('[H'), ('[I'), ('[J'), ('[K'), ('[L'), ('[M'), ('[N'), ('[O'),
1205    ('[P'), ('[Q'), ('[R'), ('[S'), ('[T'), ('[U'), ('[V'), ('[W'),
1206    ('[X'), ('[Y'), ('[Z'), (']A'), (']B'), (']C'), (']D'), (']E'),
1207    (' '),  ('{A'), ('{B'), ('{C'), ('{D'), ('{E'), ('{F'), ('{G'),
1208    ('{H'), ('{I'), ('{J'), ('{K'), ('{L'), ('{M'), ('{N'), ('{O'),
1209    ('0'),  ('1'),  ('2'),  ('3'),  ('4'),  ('5'),  ('6'),  ('7'),
1210    ('8'),  ('9'),  ('{Z'), (']F'), (']G'), (']H'), (']I'), (']J'),
1211    (']V'), ('A'),  ('B'),  ('C'),  ('D'),  ('E'),  ('F'),  ('G'),
1212    ('H'),  ('I'),  ('J'),  ('K'),  ('L'),  ('M'),  ('N'),  ('O'),
1213    ('P'),  ('Q'),  ('R'),  ('S'),  ('T'),  ('U'),  ('V'),  ('W'),
1214    ('X'),  ('Y'),  ('Z'),  (']K'), (']L'), (']M'), (']N'), (']O'),
1215    (']W'), ('}A'), ('}B'), ('}C'), ('}D'), ('}E'), ('}F'), ('}G'),
1216    ('}H'), ('}I'), ('}J'), ('}K'), ('}L'), ('}M'), ('}N'), ('}O'),
1217    ('}P'), ('}Q'), ('}R'), ('}S'), ('}T'), ('}U'), ('}V'), ('}W'),
1218    ('}X'), ('}Y'), ('}Z'), (']P'), (']Q'), (']R'), (']S'), (']T')
1219    );
1220
1221var
1222  //      save:array[0..254] of char;
1223  //      old:string;
1224  save: string;
1225  i: integer;
1226begin
1227  //      CharToOem(PChar(FText), save);
1228  save := FText;
1229  FText := '';
1230
1231
1232  for i := 0 to Length(save) - 1 do
1233  begin
1234    if Ord(save[i]) <= 127 then
1235      FText := FText + code93x[Ord(save[i])];
1236  end;
1237
1238  //Showmessage(Format('Text: <%s>', [FText]));
1239
1240  Result := Code_93;
1241  FText := save;
1242end;
1243
1244
1245function TBarcode.Code_MSI: string;
1246const
1247  tabelle_MSI: array['0'..'9'] of string[8] =
1248    (
1249    ('51515151'),    // '0'
1250    ('51515160'),    // '1'
1251    ('51516051'),    // '2'
1252    ('51516060'),    // '3'
1253    ('51605151'),    // '4'
1254    ('51605160'),    // '5'
1255    ('51606051'),    // '6'
1256    ('51606060'),    // '7'
1257    ('60515151'),    // '8'
1258    ('60515160')     // '9'
1259    );
1260
1261var
1262  i: integer;
1263  check_even, check_odd, vChecksum: integer;
1264begin
1265  Result := '60';    // Startcode
1266  check_even := 0;
1267  check_odd := 0;
1268
1269  for i := 1 to Length(FText) do
1270  begin
1271    if odd(i - 1) then
1272      check_odd := check_odd * 10 + Ord(FText[i])
1273    else
1274      check_even := check_even + Ord(FText[i]);
1275
1276    Result := Result + tabelle_MSI[FText[i]];
1277  end;
1278
1279  vChecksum := quersumme(check_odd * 2) + check_even;
1280
1281  vChecksum := vChecksum mod 10;
1282  if vChecksum > 0 then
1283    vChecksum := 10 - vChecksum;
1284
1285  Result := Result + tabelle_MSI[chr(Ord('0') + vChecksum)];
1286
1287  Result := Result + '515'; // Stopcode
1288end;
1289
1290
1291function TBarcode.Code_PostNet: string;
1292const
1293  tabelle_PostNet: array['0'..'9'] of string[10] =
1294    (
1295    ('5151A1A1A1'),    // '0'
1296    ('A1A1A15151'),    // '1'
1297    ('A1A151A151'),    // '2'
1298    ('A1A15151A1'),    // '3'
1299    ('A151A1A151'),    // '4'
1300    ('A151A151A1'),    // '5'
1301    ('A15151A1A1'),    // '6'
1302    ('51A1A1A151'),    // '7'
1303    ('51A1A151A1'),    // '8'
1304    ('51A151A1A1')     // '9'
1305    );
1306var
1307  i: integer;
1308begin
1309  Result := '51';
1310
1311  for i := 1 to Length(FText) do
1312  begin
1313    Result := Result + tabelle_PostNet[FText[i]];
1314  end;
1315  Result := Result + '5';
1316end;
1317
1318
1319function TBarcode.Code_Codabar: string;
1320type
1321  TCodabar = record
1322    c: char;
1323    Data: array[0..6] of char;
1324  end;
1325
1326const
1327  tabelle_cb: array[0..19] of TCodabar = (
1328    (c: '1'; Data: '5050615'),
1329    (c: '2'; Data: '5051506'),
1330    (c: '3'; Data: '6150505'),
1331    (c: '4'; Data: '5060515'),
1332    (c: '5'; Data: '6050515'),
1333    (c: '6'; Data: '5150506'),
1334    (c: '7'; Data: '5150605'),
1335    (c: '8'; Data: '5160505'),
1336    (c: '9'; Data: '6051505'),
1337    (c: '0'; Data: '5050516'),
1338    (c: '-'; Data: '5051605'),
1339    (c: '$'; Data: '5061505'),
1340    (c: ':'; Data: '6050606'),
1341    (c: '/'; Data: '6060506'),
1342    (c: '.'; Data: '6060605'),
1343    (c: '+'; Data: '5060606'),
1344    (c: 'A'; Data: '5061515'),
1345    (c: 'B'; Data: '5151506'),
1346    (c: 'C'; Data: '5051516'),
1347    (c: 'D'; Data: '5051615')
1348    );
1349
1350
1351  // find Codabar
1352  function Find_Codabar(c: char): integer;
1353  var
1354    i: integer;
1355  begin
1356    for i := 0 to High(tabelle_cb) do
1357    begin
1358      if c = tabelle_cb[i].c then
1359      begin
1360        Result := i;
1361        exit;
1362      end;
1363    end;
1364    Result := -1;
1365  end;
1366
1367var
1368  i, idx: integer;
1369begin
1370  Result := tabelle_cb[Find_Codabar('A')].Data + '0';
1371  for i := 1 to Length(FText) do
1372  begin
1373    idx := Find_Codabar(FText[i]);
1374    Result := Result + tabelle_cb[idx].Data + '0';
1375  end;
1376  Result := Result + tabelle_cb[Find_Codabar('B')].Data;
1377end;
1378
1379procedure TBarcode.MakeModules;
1380begin
1381  case Typ of
1382    bcCode_2_5_interleaved,
1383    bcCode_2_5_industrial,
1384    bcCode39,
1385    bcCodeEAN8,
1386    bcCodeEAN13,
1387    bcCode39Extended,
1388    bcCodeCodabar:
1389    begin
1390      if Ratio < 2.0 then
1391        Ratio := 2.0;
1392      if Ratio > 3.0 then
1393        Ratio := 3.0;
1394    end;
1395
1396    bcCode_2_5_matrix:
1397    begin
1398      if Ratio < 2.25 then
1399        Ratio := 2.25;
1400      if Ratio > 3.0 then
1401        Ratio := 3.0;
1402    end;
1403    bcCode128A,
1404    bcCode128B,
1405    bcCode128C,
1406    bcCode93,
1407    bcCode93Extended,
1408    bcCodeMSI,
1409    bcCodePostNet: ;
1410  end;
1411
1412  modules[0] := FModul;
1413  modules[1] := Round(FModul * FRatio);
1414  modules[2] := modules[1] * 3 div 2;
1415  modules[3] := modules[1] * 2;
1416end;
1417
1418
1419{
1420Draw the Barcode
1421
1422Parameter :
1423'data' holds the pattern for a Barcode.
1424A barcode begins always with a black line and
1425ends with a black line.
1426
1427The white Lines builds the space between the black Lines.
1428
1429A black line must always followed by a white Line and vica versa.
1430
1431Examples:
1432        '50505'   // 3 thin black Lines with 2 thin white Lines
1433        '606'     // 2 fat black Lines with 1 thin white Line
1434
1435        '5605015' // Error
1436
1437
1438data[] : see procedure OneBarProps
1439
1440}
1441procedure TBarcode.DoLines(Data: string; Canvas: TCanvas);
1442
1443var
1444  i: integer;
1445  lt: TBarLineType;
1446  xadd: integer;
1447  w, h: integer;
1448  a, b, c, d,     // Edges of a line (we need 4 Point because the line
1449  // is a recangle
1450  orgin: TPoint;
1451  alpha: double;
1452
1453begin
1454  xadd := 0;
1455  orgin.x := FLeft;
1456  orgin.y := FTop;
1457  alpha := FAngle * pi / 180.0;
1458
1459  with Canvas do
1460  begin
1461    Pen.Width := 1;
1462
1463    for i := 1 to Length(Data) do  // examine the pattern string
1464    begin
1465      OneBarProps(Data[i], w, lt);
1466
1467      {
1468      case data[i] of
1469        '0': begin w := modules[0]; lt := white; end;
1470        '1': begin w := modules[1]; lt := white; end;
1471        '2': begin w := modules[2]; lt := white; end;
1472        '3': begin w := modules[3]; lt := white; end;
1473
1474
1475        '5': begin w := modules[0]; lt := black; end;
1476        '6': begin w := modules[1]; lt := black; end;
1477        '7': begin w := modules[2]; lt := black; end;
1478        '8': begin w := modules[3]; lt := black; end;
1479
1480        'A': begin w := modules[0]; lt := black_half; end;
1481        'B': begin w := modules[1]; lt := black_half; end;
1482        'C': begin w := modules[2]; lt := black_half; end;
1483        'D': begin w := modules[3]; lt := black_half; end;
1484      else
1485        begin
1486          // something went wrong
1487          // mistyped pattern table
1488          raise Exception.CreateFmt('%s: internal Error', [self.ClassName]);
1489        end;
1490      end;
1491      }
1492
1493      if (lt = black) or (lt = black_half) then
1494      begin
1495        Pen.Color := clBlack;
1496      end
1497      else
1498      begin
1499        Pen.Color := clWhite;
1500      end;
1501      Brush.Color := Pen.Color;
1502
1503      if lt = black_half then
1504        H := FHeight * 2 div 5
1505      else
1506        H := FHeight;
1507
1508
1509      a.x := xadd;
1510      a.y := 0;
1511
1512      b.x := xadd;
1513      b.y := H;
1514
1515      // c.x := xadd+width;
1516      c.x := xadd + W - 1;  // 23.04.1999 Line was 1 Pixel too wide
1517      c.y := H;
1518
1519      // d.x := xadd+width;
1520      d.x := xadd + W - 1;  // 23.04.1999 Line was 1 Pixel too wide
1521      d.y := 0;
1522
1523      // a,b,c,d builds the rectangle we want to draw
1524
1525
1526      // rotate the rectangle
1527      a := Translate2D(Rotate2D(a, alpha), orgin);
1528      b := Translate2D(Rotate2D(b, alpha), orgin);
1529      c := Translate2D(Rotate2D(c, alpha), orgin);
1530      d := Translate2D(Rotate2D(d, alpha), orgin);
1531
1532      // draw the rectangle
1533      Polygon([a, b, c, d]);
1534
1535      xadd := xadd + w;
1536    end;
1537  end;
1538end;
1539
1540
1541procedure TBarcode.DrawBarcode(Canvas: TCanvas);
1542var
1543  Data: string;
1544  SaveFont: TFont;
1545  SavePen: TPen;
1546  SaveBrush: TBrush;
1547begin
1548  Savefont := TFont.Create;
1549  SavePen := TPen.Create;
1550  SaveBrush := TBrush.Create;
1551
1552  // get barcode pattern
1553  Data := MakeData;
1554
1555  try
1556    // store Canvas properties
1557    Savefont.Assign(Canvas.Font);
1558    SavePen.Assign(Canvas.Pen);
1559    SaveBrush.Assign(Canvas.Brush);
1560
1561    DoLines(Data, Canvas);    // draw the barcode
1562
1563    if FShowText then
1564      DrawText(Canvas);   // show readable Text
1565
1566    // restore old Canvas properties
1567    Canvas.Font.Assign(savefont);
1568    Canvas.Pen.Assign(SavePen);
1569    Canvas.Brush.Assign(SaveBrush);
1570  finally
1571    Savefont.Free;
1572    SavePen.Free;
1573    SaveBrush.Free;
1574  end;
1575end;
1576
1577
1578{
1579  draw contents and type/name of barcode
1580  as human readable text at the left
1581  upper edge of the barcode.
1582
1583  main use for this procedure is testing.
1584
1585  note: this procedure changes Pen and Brush
1586  of the current canvas.
1587}
1588procedure TBarcode.DrawText(Canvas: TCanvas);
1589begin
1590  with Canvas do
1591  begin
1592    Font.Size := 4;
1593    // the fixed font size is a problem, if you
1594    // use very large or small barcodes
1595
1596    Pen.Color := clBlack;
1597    Brush.Color := clWhite;
1598    TextOut(FLeft, FTop, FText);         // contents of Barcode
1599    TextOut(FLeft, FTop + 14, GetTypText); // type/name of barcode
1600  end;
1601end;
1602
1603// this function returns true for those symbols that correct them selves
1604// in case invalid data is fed. For example feeding ABCD to 128C numeric
1605// only symbol, the generated barcode will be for 0000
1606function TBarcode.BarcodeTypeChecked(AType: TBarcodeType): boolean;
1607begin
1608  result := aType in [ bcCode128A, bcCode128B, bcCode128C, bcCodeEAN8,
1609                       bcCodeEAN13 ];
1610end;
1611
1612function TBarcode.CleanEANValue(const AValue:string; const ASize: Byte): string;
1613var
1614  tmp: string;
1615  n,i: Integer;
1616begin
1617  tmp := AValue;
1618  n := Length(tmp);
1619
1620  // check if there is any strange char in string
1621  for i:=1 to n do
1622    if not (tmp[i] in ['0'..'9']) then
1623      tmp[i] := '0';
1624
1625  // enforce a ASize char string by adding a 0
1626  // verifier digit if necesary or calc it if
1627  // checksum was specified
1628  if n<ASize then begin
1629    tmp := stringofchar('0', ASize-n-1) + tmp + '0';
1630    // TODO: if not FCheckSum was specified
1631    //       resulting barcode might be invalid
1632    //       as a '0' checksum digit was forced.
1633  end;
1634
1635  if FCheckSum then
1636    Result := getEAN(copy(tmp, 1, ASize-1) + '0')
1637  else
1638    Result := copy(tmp, 1, ASize);
1639
1640end;
1641
1642
1643
1644end.
1645