Excel makro na tvorbu skenovateľných EAN kódov

Sub EAN13_BAR_CODE()
    'Modified from Barcode Font Pack v1.2 by Chaos Microsystems Inc.

    'This procedure is written for Excel but can be modified for use by Word or CorelDraw.
    'To do this deleting out the Excel or use apostrophes to convert the Excel section to comments.
    'Remove the apostrophes from the lines in the CorelDraw or Word sections.
    'I have used double apostrophes to indicate the comment lines.
    
    'This procedure is written to use the font "EAN-13".
    'If you want to use one of the other 3 fonts, "EAN-13 Half Height" or
    '"EAN-13B" or "EAN-13B Half Height" modify the value of strFONT below.
    'You must already have installed the fonts to use them in this procedure.

    Dim COUNTER As Integer
    Dim vFirst_Flag_Sequence(10) As Byte
    Dim N1 As String
    Dim N2 As String
    Dim N3_to_N7 As String
    Dim N4 As String
    Dim N5 As String
    Dim N8_to_N12 As String
    Dim vActual_digit As String
    Dim vCheck_Characters As Integer
    Dim vCenter_Guard_Character As Integer
    Dim vLeft_Hand_A As Integer
    Dim vLeft_Hand_B As Integer
    Dim vRight_Hand As Integer
    Dim vFirst_Flag_Characters As Integer
    Dim vSecond_Flag_Characters As Integer
    Dim vEAN_Sum_Odd_values As Integer
    Dim vEAN_Sum_Even_values As Integer
    Dim strEAN_No As String
    Dim EAN_CHECK_DIGIT As Integer
    Dim EAN_BARCODE As String
    Dim strFONT As String
    
    '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    'Change the font name here to use one of the 4 fonts;
    '"EAN-13", "EAN-13 Half Height" or "EAN-13B" or "EAN-13B Half Height"
    strFONT = "EAN-13"
    '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
    vFirst_Flag_Sequence(0) = 0
    vFirst_Flag_Sequence(1) = 11
    vFirst_Flag_Sequence(2) = 13
    vFirst_Flag_Sequence(3) = 14
    vFirst_Flag_Sequence(4) = 19
    vFirst_Flag_Sequence(5) = 25
    vFirst_Flag_Sequence(6) = 28
    vFirst_Flag_Sequence(7) = 21
    vFirst_Flag_Sequence(8) = 22
    vFirst_Flag_Sequence(9) = 26
    vLeft_Hand_A = 48
    vLeft_Hand_B = 64
    vRight_Hand = 80
    vFirst_Flag_Characters = 33
    vSecond_Flag_Characters = 96
    vCheck_Characters = 112
    vCenter_Guard_Character = 124
    
    'Accept only the first 12 characters as the 13th is the check digit.
    strEAN_No = Left(InputBox("Enter Bar Code number ", "BAR CODE GENERATOR"), 12)
    
    
    
    
    'Now check the entered data.
    'If strEAN_No = "" Then Cancel was selected in InputBox.
    If strEAN_No = "" Then End
    
    'If entered bar code No has less than 12 digits, warn & then close.
    If Len(strEAN_No) < 12 Then
        MsgBox Prompt:="Bar Code No" & vbLf & vbTab & strEAN_No & vbCr & "has less than 12 digits.", Buttons:=vbOKOnly, Title:="BAR CODE GENERATOR"
        End
    End If
    
    'Now check that the bar code No is a number and does not include other characters or spaces.
    For COUNTER = 1 To 12
        Select Case Mid(strEAN_No, COUNTER, 1)
            Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9
            Case Else:
                MsgBox Prompt:="Bar Code No" & vbLf & vbTab & strEAN_No & vbCr & "contains some non-number characters.", Buttons:=vbOKOnly, Title:="BAR CODE GENERATOR"
                End
        End Select
    Next
    
    
    
    
    vEAN_Sum_Odd_values = 0
    vEAN_Sum_Even_values = 0
    
    'Now commence determining the check digit.
    'Step through No to add the odd & even character positions separately.
    For COUNTER = 12 To 1 Step -1
        Select Case COUNTER
            Case 12, 10, 8, 6, 4, 2 ' Odd values
                vEAN_Sum_Odd_values = vEAN_Sum_Odd_values + Mid(strEAN_No, COUNTER, 1)
            Case 11, 9, 7, 5, 3, 1 ' Even values
                vEAN_Sum_Even_values = vEAN_Sum_Even_values + Mid(strEAN_No, COUNTER, 1)
        End Select
    Next
    
    EAN_CHECK_DIGIT = 10 - (vEAN_Sum_Odd_values * 3 + vEAN_Sum_Even_values) Mod 10
    If EAN_CHECK_DIGIT = 10 Then EAN_CHECK_DIGIT = 0
    
    'Add the check digit to the end.
    strEAN_No = strEAN_No & EAN_CHECK_DIGIT
    
    'N1 & N2 represent country codes.
    N1 = Chr$(vFirst_Flag_Characters + Mid(strEAN_No, 1, 1))
    N2 = Chr$(vSecond_Flag_Characters + Mid(strEAN_No, 2, 1))
    
    N4 = Chr$(vCheck_Characters + Mid(strEAN_No, 13, 1)) ' Right No
    N5 = Chr$(vCenter_Guard_Character) 'Center guard
    
    N3_to_N7 = ""
    N8_to_N12 = ""
    
    For COUNTER = 3 To 12
        vActual_digit = Mid(strEAN_No, COUNTER, 1)
        Select Case COUNTER
            Case 3 To 7
                If (vFirst_Flag_Sequence(Mid(strEAN_No, 1, 1)) And (2 ^ (7 - COUNTER))) <> 0 Then
                    N3_to_N7 = N3_to_N7 & Chr$(vLeft_Hand_B + vActual_digit)
               Else
                    N3_to_N7 = N3_to_N7 & Chr$(vLeft_Hand_A + vActual_digit)
                End If
            Case 8 To 12
                N8_to_N12 = N8_to_N12 & Chr$(vRight_Hand + vActual_digit)
            Case 13
        End Select
    Next
    
    EAN_BARCODE = N1 & N2 & N3_to_N7 & N5 & N8_to_N12 & N4
    
    
    '********************************************************************
    'For Excel
    ThisWorkbook.Sheets(1).Cells(2, 3) = EAN_BARCODE
    ThisWorkbook.Sheets(1).Cells(2, 3).Font.Name = strFONT
    ThisWorkbook.Sheets(1).Cells(2, 3).Font.Size = 36
    
    ''********************************************************************
    ''For Word
    'Dim TEXTFRAME1 As Shape
    'Set TEXTFRAME1 = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 200, 300, 110, 70)
    'TEXTFRAME1.Line.Visible = msoFalse
    'TEXTFRAME1.TextFrame.TextRange.Text = EAN_BARCODE
    'TEXTFRAME1.TextFrame.TextRange.Font.Name = strFONT
    'TEXTFRAME1.TextFrame.TextRange.Font.Size = 36
   
    
    ''********************************************************************
    ''For CorelDraw
    'Dim shDATA_OBJECT As Shape
    ''Position the new text at 0,0.
    'Set shDATA_OBJECT = ActiveLayer.CreateArtisticText(0, 0, EAN_BARCODE)
    'shDATA_OBJECT.Text.FontProperties.Name = strFONT
    'shDATA_OBJECT.Text.FontProperties.Size = 36
    'shDATA_OBJECT.Text.FontProperties.Style = cdrNormalFontStyle
    'shDATA_OBJECT.Text.AlignProperties.Alignment = cdrCenterAlignment

End Sub