[HaBo]

function GenSerial(Name: String):String;
  function GetSerialToken(c: Char): String;
  var
    str1: String;
    rest, durch: Integer;
  begin
    str1 := '';
    rest  :=  (ord(c)-$14);
    durch :=  (ord(c)-$14);
    While (durch > 0) Do
      begin
        rest := durch mod $0A;
        durch := durch div $0A;
        if ((rest + $30) < $3A) Then
          str1 := str1 + chr(rest + $30)
        Else
          str1 := str1 + chr(rest + $37);
      end;
    result := str1;
  end;
  function TableConversion(Token: String):String;
  var
    i: Integer;
  begin
    case StrToIntDef(Token,91) of
      11: result := 'A';
      22: result := 'B';
      33: result := 'C';
      44: result := 'D';
      55: result := 'E';
      66: result := 'F';
      77: result := 'G';
      88: result := 'H';
      99: result := 'J';
      00: result := 'K';
      12: result := 'L';
      23: result := 'M';
      34: result := 'N';
      45: result := 'O';
      56: result := 'P';
      67: result := 'R';
      78: result := 'S';
      89: result := 'T';
      90: result := 'U';
      01: result := 'W';
      else result := Token;
    end;
  end;
  function FinalTableConversion(str: String):String;
  var
    i: Integer;
    token: String;
  begin
    result := str;
    i := 1;
    While i < Length(result) Do
      begin
        Token := TableConversion(result[i]+result[i+1]);
        If Token <> result[i]+result[i+1] Then
          begin
            Delete(result,i,2);
            Insert(Token,result,i);
          end;
        Inc(i);  
      end;
  end;
  procedure ReverseTokenOrder(const res: TStringList; var new: TStringList);
  var
    i: Integer;
  begin
    new := TStringList.Create;
    For i := res.Count -1 DownTo 0 Do
      begin
        new.Add(res.Strings[i]);
      end;
  end;
var
  i: Integer;
  strodd: TStringList;
  streven, strevenrev: TStringList;
  strfinal: String;
begin
  strfinal := '';
  streven := TStringList.Create;
  strodd := TStringList.Create;
  For i := Length(Name) DownTo 1 Do
    begin
      If odd((ord(Name[i])-$14)) Then
        begin
          strodd.Add(TableConversion(ReverseString(GetSerialToken(Name[i]))));
        end else
        begin
          streven.Add(TableConversion(ReverseString(GetSerialToken(Name[i]))));
        end;
      end;
  ReverseTokenOrder(streven, strevenrev);
  For i:= 0 To streven.Count -1 Do
    begin
      strfinal := strfinal + strevenrev.Strings[i];
    end;
  For i:= 0 To strodd.Count -1 Do
    begin
      strfinal := strfinal + strodd.Strings[i];
    end;
  result := FinalTableConversion(strfinal);
end;