rm_asbarcode.pas

这是一个功能强大

  inherited;
end;

procedure TAsBarcode.Assign(Source: TPersistent);
var
  BSource: TAsBarcode;
begin
  if Source is TAsBarcode then
  begin
    BSource := TAsBarcode(Source);
    FHeight := BSource.FHeight;
    FText := BSource.FText;
    FTop := BSource.FTop;
    FLeft := BSource.FLeft;
    FModul := BSource.FModul;
    FRatio := BSource.FRatio;
    FTyp := BSource.FTyp;
    FCheckSum := BSource.FCheckSum;
    FShowText := BSource.FShowText;
    FShowTextPosition := BSource.FShowTextPosition; // 15.05.2003
    FAngle := BSource.FAngle;
    FColor := BSource.FColor;
    FColorBar := BSource.FColorBar;
    FCheckSumMethod := BSource.FCheckSumMethod;
    FOnChange := BSource.FOnChange;
  end
  else
    inherited; // 15.05.2003
end;


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



{ set Modul Width  }

procedure TAsBarcode.SetModul(v: integer);
begin
	if v < 1 then v := 1;
  if v > 50 then v := 50;

  if (v >= 1) and (v <= 50) then
  begin
    FModul := v;
    DoChange;
  end;
end;


{
calculate the width and the linetype of a sigle bar


  Code   Line-Color      Width               Height
------------------------------------------------------------------
  '0'   white           100%                full
  '1'   white           100%*Ratio          full
  '2'   white           150%*Ratio          full
  '3'   white           200%*Ratio          full
  '5'   black           100%                full
  '6'   black           100%*Ratio          full
  '7'   black           150%*Ratio          full
  '8'   black           200%*Ratio          full
  'A'   black           100%                2/5  (used for PostNet)
  'B'   black           100%*Ratio          2/5  (used for PostNet)
  'C'   black           150%*Ratio          2/5  (used for PostNet)
  'D'   black           200%*Ratio          2/5  (used for PostNet)
}

procedure TAsBarcode.OneBarProps(code: char; var Width: integer; var lt: TBarLineType);
begin
  case code of
    '0': begin width := modules[0]; lt := white; end;
    '1': begin width := modules[1]; lt := white; end;
    '2': begin width := modules[2]; lt := white; end;
    '3': begin width := modules[3]; lt := white; end;


    '5': begin width := modules[0]; lt := black; end;
    '6': begin width := modules[1]; lt := black; end;
    '7': begin width := modules[2]; lt := black; end;
    '8': begin width := modules[3]; lt := black; end;

    'A': begin width := modules[0]; lt := black_half; end;
    'B': begin width := modules[1]; lt := black_half; end;
    'C': begin width := modules[2]; lt := black_half; end;
    'D': begin width := modules[3]; lt := black_half; end;
  else
    begin
   {something went wrong  :-(  }
   {mistyped pattern table}
      raise Exception.CreateFmt('%s: internal Error', [self.ClassName]);
    end;
  end;
end;


function TAsBarcode.MakeData: string;
var
  i: integer;
begin
  {calculate the with of the different lines (modules)}
  MakeModules;


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


  {get the pattern of the barcode}
  case Typ of
    bcCode_2_5_interleaved: Result := Code_2_5_interleaved;
    bcCode_2_5_industrial: Result := Code_2_5_industrial;
    bcCode_2_5_matrix: Result := Code_2_5_matrix;
    bcCode39: Result := Code_39;
    bcCode39Extended: Result := Code_39Extended;
    bcCode128A,
      bcCode128B,
      bcCode128C,
      bcCodeEAN128A,
      bcCodeEAN128B,
      bcCodeEAN128C: Result := Code_128;
    bcCode93: Result := Code_93;
    bcCode93Extended: Result := Code_93Extended;
    bcCodeMSI: Result := Code_MSI;
    bcCodePostNet: Result := Code_PostNet;
    bcCodeCodabar: Result := Code_Codabar;
    bcCodeEAN8: Result := Code_EAN8;
    bcCodeEAN13: Result := Code_EAN13;
    bcCodeUPC_A: Result := Code_UPC_A;
    bcCodeUPC_E0: Result := Code_UPC_E0;
    bcCodeUPC_E1: Result := Code_UPC_E1;
    bcCodeUPC_Supp2: Result := Code_Supp2;
    bcCodeUPC_Supp5: Result := Code_Supp5;
  else
    raise Exception.CreateFmt('%s: wrong BarcodeType', [self.ClassName]);
  end;

{
Showmessage(Format('Data <%s>', [Result]));
}
end;



function TAsBarcode.GetWidth: integer;
var
  data: string;
  i: integer;
  w: integer;
  lt: TBarLineType;
begin
  Result := 0;

  {get barcode pattern}
  data := MakeData;

  for i := 1 to Length(data) do {examine the pattern string}
  begin
    OneBarProps(data[i], w, lt);
    Inc(Result, w);
  end;
end;

procedure TAsBarcode.SetWidth(Value: integer);
var
  data: string;
  i: integer;
  w, wtotal: integer;
  lt: TBarLineType;
begin
  wtotal := 0;

  {get barcode pattern}
  data := MakeData;

  for i := 1 to Length(data) do {examine the pattern string}
  begin
    OneBarProps(data[i], w, lt);
    Inc(wtotal, w);
  end;


  {
  wtotal:  current width of barcode
  Value :  new width of barcode



  }

  if wtotal > 0 then { don't divide by 0 ! }
    SetModul((FModul * Value) div wtotal);
end;



function TAsBarcode.DoCheckSumming(const data: string): string;
begin
  case FCheckSumMethod of

    csmNone:
      Result := data;
    csmModulo10:
      Result := CheckSumModulo10(data);

  end;
end;




{
////////////////////////////// EAN /////////////////////////////////////////
}


{
////////////////////////////// EAN8 /////////////////////////////////////////
}

{Pattern for Barcode EAN Charset A}
     {L1   S1   L2   S2}
const tabelle_EAN_A: array['0'..'9'] of string =
  (
    ('2605'), { 0 }
    ('1615'), { 1 }
    ('1516'), { 2 }
    ('0805'), { 3 }
    ('0526'), { 4 }
    ('0625'), { 5 }
    ('0508'), { 6 }
    ('0706'), { 7 }
    ('0607'), { 8 }
    ('2506') { 9 }
    );

{Pattern for Barcode EAN Charset C}
     {S1   L1   S2   L2}
const tabelle_EAN_C: array['0'..'9'] of string =
  (
    ('7150'), { 0 }
    ('6160'), { 1 }
    ('6061'), { 2 }
    ('5350'), { 3 }
    ('5071'), { 4 }
    ('5170'), { 5 }
    ('5053'), { 6 }
    ('5251'), { 7 }
    ('5152'), { 8 }
    ('7051') { 9 }
    );


function TAsBarcode.Code_EAN8: string;
var
  i: integer;
  tmp: string;
begin
  if FCheckSum then
  begin
    tmp := SetLen(7);
    tmp := DoCheckSumming(copy(tmp, length(tmp) - 6, 7));
  end
  else
    tmp := SetLen(8);

{$IFDEF ASSERT_SUPPORTED}
  Assert(Length(tmp) = 8, 'Invalid Text len (EAN8)');
{$ENDIF}
  result := '505'; {Startcode}

  for i := 1 to 4 do
    result := result + tabelle_EAN_A[tmp[i]];

  result := result + '05050'; {Center Guard Pattern}

  for i := 5 to 8 do
    result := result + tabelle_EAN_C[tmp[i]];

  result := result + '505'; {Stopcode}
end;

{////////////////////////////// EAN13 ///////////////////////////////////////}

{Pattern for Barcode EAN Zeichensatz B}
     {L1   S1   L2   S2}
const tabelle_EAN_B: array['0'..'9'] of string =
  (
    ('0517'), { 0 }
    ('0616'), { 1 }
    ('1606'), { 2 }
    ('0535'), { 3 }
    ('1705'), { 4 }
    ('0715'), { 5 }
    ('3505'), { 6 }
    ('1525'), { 7 }
    ('2515'), { 8 }
    ('1507') { 9 }
    );

{Zuordung der Paraitaetsfolgen f黵 EAN13}
const tabelle_ParityEAN13: array[0..9, 1..6] of char =
  (
    ('A', 'A', 'A', 'A', 'A', 'A'), { 0 }
    ('A', 'A', 'B', 'A', 'B', 'B'), { 1 }
    ('A', 'A', 'B', 'B', 'A', 'B'), { 2 }
    ('A', 'A', 'B', 'B', 'B', 'A'), { 3 }
    ('A', 'B', 'A', 'A', 'B', 'B'), { 4 }
    ('A', 'B', 'B', 'A', 'A', 'B'), { 5 }
    ('A', 'B', 'B', 'B', 'A', 'A'), { 6 }
    ('A', 'B', 'A', 'B', 'A', 'B'), { 7 }
    ('A', 'B', 'A', 'B', 'B', 'A'), { 8 }
    ('A', 'B', 'B', 'A', 'B', 'A') { 9 }
    );

function TAsBarcode.Code_EAN13: string;
var
  i, LK: integer;
  tmp: string;
begin
  if FCheckSum then
  begin
    tmp := SetLen(12);
    tmp := DoCheckSumming(tmp);
  end
  else
    tmp := SetLen(13);

{$IFDEF ASSERT_SUPPORTED}
  Assert(Length(tmp) = 13, 'Invalid Text len (EAN13)');
{$ENDIF}

  LK := StrToInt(tmp[1]);
  tmp := copy(tmp, 2, 12);

  result := '505'; {Startcode}

  for i := 1 to 6 do
  begin
    case tabelle_ParityEAN13[LK, i] of
      'A': result := result + tabelle_EAN_A[tmp[i]];
      'B': result := result + tabelle_EAN_B[tmp[i]];
      'C': result := result + tabelle_EAN_C[tmp[i]];
    end;
  end;

  result := result + '05050'; {Center Guard Pattern}

  for i := 7 to 12 do
    result := result + tabelle_EAN_C[tmp[i]];

  result := result + '505'; {Stopcode}
end;

{Pattern for Barcode 2 of 5}
const tabelle_2_5: array['0'..'9', 1..5] of char =
  (
    ('0', '0', '1', '1', '0'), {'0'}
    ('1', '0', '0', '0', '1'), {'1'}
    ('0', '1', '0', '0', '1'), {'2'}
    ('1', '1', '0', '0', '0'), {'3'}
    ('0', '0', '1', '0', '1'), {'4'}
    ('1', '0', '1', '0', '0'), {'5'}
    ('0', '1', '1', '0', '0'), {'6'}
    ('0', '0', '0', '1', '1'), {'7'}
    ('1', '0', '0', '1', '0'), {'8'}
    ('0', '1', '0', '1', '0') {'9'}
    );

function TAsBarcode.Code_2_5_interleaved: string;
var
  i, j: integer;
  c: char;

begin
  result := '5050'; {Startcode}

  for i := 1 to Length(FText) div 2 do
  begin
    for j := 1 to 5 do
    begin
      if tabelle_2_5[FText[i * 2 - 1], j] = '1' then
        c := '6'
      else
        c := '5';
      result := result + c;
      if tabelle_2_5[FText[i * 2], j] = '1' then
        c := '1'
      else
        c := '0';
      result := result + c;
    end;
  end;

  result := result + '605'; {Stopcode}
end;


function TAsBarcode.Code_2_5_industrial: string;
var
  i, j: integer;
begin
  result := '606050'; {Startcode}

  for i := 1 to Length(FText) do
  begin
    for j := 1 to 5 do
    begin
      if tabelle_2_5[FText[i], j] = '1' then
        result := result + '60'
      else
        result := result + '50';
    end;
  end;

  result := result + '605060'; {Stopcode}
end;

function TAsBarcode.Code_2_5_matrix: string;
var
  i, j: integer;
  c: char;
begin
  result := '705050'; {Startcode}

  for i := 1 to Length(FText) do
  begin
    for j := 1 to 5 do
    begin
      if tabelle_2_5[FText[i], j] = '1' then
        c := '1'
      else
        c := '0';

    {Falls i ungerade ist dann mache L點ke zu Strich}
      if odd(j) then
        c := chr(ord(c) + 5);
      result := result + c;
    end;
    result := result + '0'; {L點ke zwischen den Zeichen}
  end;

  result := result + '70505'; {Stopcode}
end;


function TAsBarcode.Code_39: string;

type TCode39 =
  record
    c: char;
    data: array[0..9] of char;
    chk: shortint;
  end;

const tabelle_39: array[0..43] of TCode39 = (
    (c: '0'; data: '505160605'; chk: 0),
    (c: '1'; data: '605150506'; chk: 1),
    (c: '2'; data: '506150506'; chk: 2),
    (c: '3'; data: '606150505'; chk: 3),
    (c: '4'; data: '505160506'; chk: 4),
    (c: '5'; data: '605160505'; chk: 5),
    (c: '6'; data: '506160505'; chk: 6),
    (c: '7'; data: '505150606'; chk: 7),
    (c: '8'; data: '605150605'; chk: 8),
    (c: '9'; data: '506150605'; chk: 9),
    (c: 'A'; data: '605051506'; chk: 10),
    (c: 'B'; data: '506051506'; chk: 11),
    (c: 'C'; data: '606051505'; chk: 12),
    (c: 'D'; data: '505061506'; chk: 13),
    (c: 'E'; data: '605061505'; chk: 14),
    (c: 'F'; data: '506061505'; chk: 15),
    (c: 'G'; data: '505051606'; chk: 16),
    (c: 'H'; data: '605051605'; chk: 17),
    (c: 'I'; data: '506051605'; chk: 18),
    (c: 'J'; data: '505061605'; chk: 19),
    (c: 'K'; data: '605050516'; chk: 20),
    (c: 'L'; data: '506050516'; chk: 21),
    (c: 'M'; data: '606050515'; chk: 22),
    (c: 'N'; data: '505060516'; chk: 23),
    (c: 'O'; data: '605060515'; chk: 24),
    (c: 'P'; data: '506060515'; chk: 25),
    (c: 'Q'; data: '505050616'; chk: 26),
    (c: 'R'; data: '605050615'; chk: 27),
    (c: 'S'; data: '506050615'; chk: 28),
    (c: 'T'; data: '505060615'; chk: 29),
    (c: 'U'; data: '615050506'; chk: 30),
    (c: 'V'; data: '516050506'; chk: 31),
    (c: 'W'; data: '616050505'; chk: 32),
    (c: 'X'; data: '515060506'; chk: 33),
    (c: 'Y'; data: '615060505'; chk: 34),
    (c: 'Z'; data: '516060505'; chk: 35),
    (c: '-'; data: '515050606'; chk: 36),
    (c: '.'; data: '615050605'; chk: 37),
    (c: ' '; data: '516050605'; chk: 38),
    (c: '*'; data: '515060605'; chk: 0),
    (c: '$'; data: '515151505'; chk: 39),
    (c: '/'; data: '515150515'; chk: 40),
    (c: '+'; data: '515051515'; chk: 41),
    (c: '%'; data: '505151515'; chk: 42)
    );


  function FindIdx(z: char): integer;
  var
    i: integer;
  begin
    for i := 0 to High(tabelle_39) do
    begin
      if z = tabelle_39[i].c then
      begin
        result := i;
        exit;
      end;
    end;
    result := -1;
  end;

var
  i, idx: integer;
  checksum: integer;

begin
  checksum := 0;
  {Startcode}
  result := tabelle_39[FindIdx('*')].data + '0';

  for i := 1 to Length(FText) do
  begin
    idx := FindIdx(FText[i]);
    if idx < 0 then
      continue;
    result := result + tabelle_39[idx].data + '0';
    Inc(checksum, tabelle_39[idx].chk);
  end;

  {Calculate Checksum Data}
  if FCheckSum then
  begin
    checksum := checksum mod 43;
    for i := 0 to High(tabelle_39) do
      if checksum = tabelle_39[i].chk then
      begin
        result := result + tabelle_39[i].data + '0';
        break;
      end;
  end;

  {Stopcode}
  result := result + tabelle_39[FindIdx('*')].data;
end;

function TAsBarcode.Code_39Extended: string;

const code39x: array[0..127] of string[2] =
  (
    ('%U'), ('$A'), ('$B'), ('$C'), ('$D'), ('$E'), ('$F'), ('$G'),
    ('$H'), ('$I'), ('$J'), ('$K'), ('$L'), ('$M'), ('$N'), ('$O'),
    ('$P'), ('$Q'), ('$R'), ('$S'), ('$T'), ('$U'), ('$V'), ('$W'),
    ('$X'), ('$Y'), ('$Z'), ('%A'), ('%B'), ('%C'), ('%D'), ('%E'),
    (' '), ('/A'), ('/B'), ('/C'), ('/D'), ('/E'), ('/F'), ('/G'),
    ('/H'), ('/I'), ('/J'), ('/K'), ('/L'), ('/M'), ('/N'), ('/O'),
    ('0'), ('1'), ('2'), ('3'), ('4'), ('5'), ('6'), ('7'),
    ('8'), ('9'), ('/Z'), ('%F'), ('%G'), ('%H'), ('%I'), ('%J'),