// Delphi Encoder Class for UPC/EAN
// Copyright 2005 by MW6 Technologies Inc. All rights reserved.
//
// This code may not be modified or distributed unless you purchase
// the license from MW6.
unit UPCEAN;

interface

uses
   SysUtils;

type
   TUPCEAN = class
   private
        StrLen: Integer;
        CheckSum: Integer;
        Data: string;
        CharSet: string;
        EncodedMessage: string;
        Buf: array[0..255] of Char;
        Buf_1: array[0..10] of Char;

        function GetCheckDigit(var src: string): Integer;
        function UPCE2UPCA(var src: string): string;

   public
        constructor Create; overload;

        function EAN13(var Src: string): string;
        function EAN8(var Src: string): string;
        function UPCA(var Src: string): string;
        function UPCE(var Src: string): string;
   end;

implementation

constructor TUPCEAN.Create;
begin
  inherited;
end;

function TUPCEAN.GetCheckDigit(var Src: string): Integer;
var
   I: integer;
   tmp: array[0..255] of Char;
begin
   StrLen := Length(Src);
   CheckSum := 0;

   StrPCopy(tmp, Src);
   for I := 1 to StrLen do
   begin
      if (I mod 2 = 1) then
        CheckSum := CheckSum + (Ord(tmp[StrLen - I]) - Ord('0')) * 3
      else
        CheckSum := CheckSum + Ord(tmp[StrLen - I]) - Ord('0');
   end;

    CheckSum := CheckSum mod 10;
    If CheckSum <> 0 then
        CheckSum := 10 - CheckSum;

    Result := CheckSum;
end;

function TUPCEAN.UPCE2UPCA(var Src: string): string;
var
    tmp: array[0..20] of Char;
begin
    StrPCopy(tmp, Src);
    case (Ord(tmp[6]) - Ord('0')) of
        0: Result := Copy(Src, 1, 3) + Copy(Src, 7, 1) + '0000' + Copy(Src, 4, 3);
        1: Result := Copy(Src, 1, 3) + Copy(Src, 7, 1) + '0000' + Copy(Src, 4, 3);
        2: Result := Copy(Src, 1, 3) + Copy(Src, 7, 1) + '0000' + Copy(Src, 4, 3);
        3: Result := Copy(Src, 1, 4) + '00000' + Copy(Src, 5, 2);
        4: Result := Copy(Src, 1, 5) + '00000' + Copy(Src, 6, 1);
        5: Result := Copy(Src, 1, 6) + '0000' + Copy(Src, 7, 1);
        6: Result := Copy(Src, 1, 6) + '0000' + Copy(Src, 7, 1);
        7: Result := Copy(Src, 1, 6) + '0000' + Copy(Src, 7, 1);
        8: Result := Copy(Src, 1, 6) + '0000' + Copy(Src, 7, 1);
        9: Result := Copy(Src, 1, 6) + '0000' + Copy(Src, 7, 1);
    end;
end;

function TUPCEAN.EAN13(var Src: string): string;
var
    I: Integer;
begin
    Data := Src;
    StrLen := Length(Src);

    // check length to make sure Data has 12 characters
    if StrLen < 12 then
    begin
        while Length(Data) < 12 do
        begin
           Data := Data + '0';
        end;
    end
    else if StrLen > 12 then
        Data := Copy(Data, 1, 12);

    StrPCopy(Buf, Data);
    // choose character set depending on the first character of string
    case (Ord(Buf[0]) - Ord('0')) of
        0: CharSet := 'AAAAAA';
        1: CharSet := 'AABABB';
        2: CharSet := 'AABBAB';
        3: CharSet := 'AABBBA';
        4: CharSet := 'ABAABB';
        5: CharSet := 'ABBAAB';
        6: CharSet := 'ABBBAA';
        7: CharSet := 'ABABAB';
        8: CharSet := 'ABABBA';
        9: CharSet := 'ABBABA';
    end;
    StrPCopy(Buf_1, CharSet);

    EncodedMessage := '' + Chr(Ord(Buf[0]) - Ord('0') + 192) + '(';
    for I := 2 to 7 do
    begin
        if Buf_1[I - 2]= 'A' then
            EncodedMessage := EncodedMessage + Buf[I - 1]
        else if Buf_1[I - 2]= 'B' then
            EncodedMessage := EncodedMessage + Chr(Ord(Buf[I - 1]) - Ord('0') + Ord('Q'));
    end;

    EncodedMessage := EncodedMessage + '*';
    for I := 8 to 12 do
    begin
        EncodedMessage := EncodedMessage + Chr(Ord(Buf[I - 1]) - Ord('0') + Ord('A'));
    end;

    EncodedMessage := EncodedMessage + Chr(GetCheckDigit(Data) + Ord('A'));
    EncodedMessage := EncodedMessage + ')';

    Result := EncodedMessage;
end;

function TUPCEAN.EAN8(var Src: string): string;
var
    I: Integer;
begin
    Data := Src;
    StrLen := Length(Src);

    // check length to make sure Data has 7 characters
    if StrLen < 7 then
    begin
        while Length(Data) < 7 do
        begin
           Data := Data + '0'
        end;
    end
    else if StrLen > 7 then
        Data := Copy(Data, 1, 7);

    StrPCopy(Buf, Data);
    EncodedMessage := '(';
    for I := 1 to 4 do
    begin
        EncodedMessage := EncodedMessage + Buf[I - 1];
    end;

    EncodedMessage := EncodedMessage + '*';
    for I := 5 to 7 do
    begin
        EncodedMessage := EncodedMessage + Chr(Ord(Buf[I - 1]) - Ord('0') + Ord('A'));
    end;

    EncodedMessage := EncodedMessage + Chr(GetCheckDigit(Data) + Ord('A'));
    EncodedMessage := EncodedMessage + ')';

    Result := EncodedMessage;
end;

function TUPCEAN.UPCA(var Src: string): string;
var
    I: Integer;
    CheckDigit: Integer;
begin
    Data := Src;
    StrLen := Length(Src);

    // check length to make sure Data has 11 characters
    if StrLen < 11 then
    begin
        while Length(Data) < 11 do
        begin
           Data := Data + '0';
        end;
    end
    else if StrLen > 11 then
        Data := Copy(Data, 1, 11);

    StrPCopy(Buf, Data);
    EncodedMessage := '' + Chr(Ord(Buf[0]) - Ord('0') + 192) + '(';
    for I := 2 to 6 do
    begin
        EncodedMessage := EncodedMessage + Buf[I - 1];
    end;

    EncodedMessage := EncodedMessage + '*';
    for I := 7 to 11 do
    begin
        EncodedMessage := EncodedMessage + Chr(Ord(Buf[I - 1]) - Ord('0') + Ord('A'));
    end;

    CheckDigit := GetCheckDigit(Data);
    EncodedMessage := EncodedMessage + Chr(CheckDigit + Ord('q'));
    EncodedMessage := EncodedMessage + ')' + Chr(CheckDigit + 192);

    Result := EncodedMessage;
end;

function TUPCEAN.UPCE(var Src: string): string;
var
    I: Integer;
    CheckDigit: Integer;
    tmp: string;
begin
    Data := Src;
    StrLen := Length(Src);

    // check length to make sure Data has 6 characters
    if StrLen < 6 then
    begin
        while Length(Data) < 6 do
        begin
           Data := Data + '0'
        end;
    end
    else if StrLen > 6 then
        Data := Copy(Data, 1, 6);

    Data := '0' + Data;

    StrPCopy(Buf, Data);

    tmp := UPCE2UPCA(Data);
    CheckDigit := GetCheckDigit(tmp);
    // choose character set depending on the check digit value
    case CheckDigit of
        0: CharSet := 'BBBAAA';
        1: CharSet := 'BBABAA';
        2: CharSet := 'BBAABA';
        3: CharSet := 'BBAAAB';
        4: CharSet := 'BABBAA';
        5: CharSet := 'BAABBA';
        6: CharSet := 'BAAABB';
        7: CharSet := 'BABABA';
        8: CharSet := 'BABAAB';
        9: CharSet := 'BAABAB';
    end;
    StrPCopy(Buf_1, CharSet);

    EncodedMessage := '' + Chr(192) + '(';
    for I := 2 to 7 do
    begin
        if Buf_1[I - 2]= 'A' then
            EncodedMessage := EncodedMessage + Buf[I - 1]
        else if Buf_1[I - 2]= 'B' then
            EncodedMessage := EncodedMessage + Chr(Ord(Buf[I - 1]) - Ord('0') + Ord('Q'));
    end;

    EncodedMessage := EncodedMessage + '+' + Chr(CheckDigit + 192);
    Result := EncodedMessage;
end;

end.