Public Sub EAN13CODE(Code, BarCode)

'

'П/программа кодирования кодом EAN13

'

Dim R As Double

Dim A, B, C, ISP

A = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")

B = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")

C = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j")

ISP = Array(Array("A", "A", "A", "A", "A", "A"), _

            Array("A", "A", "B", "A", "B", "B"), _

            Array("A", "A", "B", "B", "A", "B"), _

            Array("A", "A", "B", "B", "B", "A"), _

            Array("A", "B", "A", "A", "B", "B"), _

            Array("A", "B", "B", "A", "A", "B"), _

            Array("A", "B", "B", "B", "A", "A"), _

            Array("A", "B", "A", "B", "A", "B"), _

            Array("A", "B", "A", "B", "B", "A"), _

            Array("A", "B", "B", "A", "B", "A"))

'

' Проверки

'

    I = Len(Code)

If I = 12 Then

'

'Расчет контрольной цифры

'

      CountParity = 0                                         '

    For I = 2 To 12 Step 2                                    'складываем

      CountParity = CountParity + Int(Mid(Code, I, 1))        'четные цифры

    Next I                                                    '

      CountNotParity = 0                                      '

    For I = 1 To 11 Step 2                                    'складываем

      CountNotParity = CountNotParity + CInt(Mid(Code, I, 1)) 'нечетные цифры

    Next I                                                    '

        ControlData = CountParity * 3 + CountNotParity        'Сумма цифр на четных и нечетных позициях

        R = ControlData / 10        'Результат деления четных и нечетных цифр на 10

        If R - Int(R) = 0 Then      'Если число кратно 10

            ControlData = 0         'то контрольное число найдено

        Else                        'если нет, то

            I = 0

            Do                             'дополняем

             I = I + 1                     'число,

             ControlData = ControlData + 1 'до ближайшего

             R = ControlData / 10          'кратного 10

             If R - Int(R) = 0 Then        '

                ControlData = I

             Exit Do

             End If

            Loop                           '

        End If

     ControlData = ControlData

'

'Сборка штрих-кода

'

    j = CInt(Mid(Code, 1, 1))              '(13эл) Исполнение цифровых знаков

    BarCode = Chr(Asc(Mid(Code, 1, 1)) - 13)        'Флаг кода, цифра без штриха

    BarCode = BarCode & "!"                                        'Краевой знак

    BarCode = BarCode & (A(CInt(Mid(Code, 2, 1))))  '(12эл) всегда А

   For I = 1 To 5                                    'Кодируем следующие 5 элементов

    If ISP(j)(I) = "A" Then

       BarCode = BarCode & (A(CInt(Mid(Code, I + 2, 1)))) 'элемент А

    Else

       BarCode = BarCode & (B(CInt(Mid(Code, I + 2, 1)))) 'элемент B

    End If

   Next I

    BarCode = BarCode & "-"            'Разделительный знак

  For I = 8 To 12                                   'Кодируем следующие 6 элементов

    BarCode = BarCode & (C(CInt(Mid(Code, I, 1))))  '

  Next I

    BarCode = BarCode & C(ControlData)    'Контрольная цифра

    BarCode = BarCode & "!"                               'Краевой знак

Else

'

' если число позиций в коде не 12

'

End If

End Sub