'计算EAN13校验位
Private Function Get_EAN_CheckSum(rawString As String)

    Dim checkSum As Integer
    checkSum = 0

    For i = 2 To 12 Step 2
        checkSum = checkSum + Val(Mid$(rawString, i, 1))
    Next

    checkSum = checkSum * 3
    For i = 1 To 11 Step 2
        checkSum = checkSum + Val(Mid$(rawString, i, 1))
    Next

    '函数返回值
    Get_EAN_CheckSum = (10 - (checkSum Mod 10)) Mod 10

End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'填充EAN码区边界
Private Function Fill_EAN_Bounds(ByVal x As Integer, ByVal y As Integer)

    '初始化码区尺寸、背景色
    For i = 1 To 100
       Cells(y, x + i).ColumnWidth = 0.2
       Cells(y, x + i).RowHeight = 100
       Cells(y, x + i).Interior.ColorIndex = 0
       
       Cells(y + 1, x + i).ColumnWidth = 0.2
       Cells(y + 1, x + i).RowHeight = 20
       Cells(y + 1, x + i).Interior.ColorIndex = 0
    Next
      
    '初始化码区左侧起始线
    Cells(y, x + 1).Interior.ColorIndex = 1
    Cells(y + 1, x + 1).Interior.ColorIndex = 1

    Cells(y, x + 2).Interior.ColorIndex = 0
    Cells(y + 1, x + 2).Interior.ColorIndex = 0

    Cells(y, x + 3).Interior.ColorIndex = 1
    Cells(y + 1, x + 3).Interior.ColorIndex = 1

    '初始化码区中间线
    Cells(y, x + 46).Interior.ColorIndex = 0
    Cells(y + 1, x + 46).Interior.ColorIndex = 0

    Cells(y, x + 47).Interior.ColorIndex = 1
    Cells(y + 1, x + 47).Interior.ColorIndex = 1

    Cells(y, x + 48).Interior.ColorIndex = 0
    Cells(y + 1, x + 48).Interior.ColorIndex = 0

    Cells(y, x + 49).Interior.ColorIndex = 1
    Cells(y + 1, x + 49).Interior.ColorIndex = 1

    Cells(y, x + 50).Interior.ColorIndex = 0
    Cells(y + 1, x + 50).Interior.ColorIndex = 0

    '初始化码区右侧终止线
    Cells(y, x + 93).Interior.ColorIndex = 1
    Cells(y + 1, x + 93).Interior.ColorIndex = 1

    Cells(y, x + 94).Interior.ColorIndex = 0
    Cells(y + 1, x + 94).Interior.ColorIndex = 0

    Cells(y, x + 95).Interior.ColorIndex = 1
    Cells(y + 1, x + 95).Interior.ColorIndex = 1

    '函数返回值
    Fill_EAN_Bounds = 0

End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'填充EAN13条码线
Private Function Fill_EAN_Lines(ByVal x As Integer, ByVal y As Integer, ByVal n As Integer)

    For i = 0 To 6
            Cells(y, x + i).Interior.ColorIndex = IIf(n And (2 ^ (6 - i)), 1, 0)
    Next

    '函数返回值
    Fill_EAN_Lines = 0

End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'主过程
Private Sub worksheet_change(ByVal Target As Range)

    '焦点不在目标区域则退出
    If Target.Address <> "$A$1" Then
        Exit Sub
    End If
    
    '初始化参量数组
    Dim preModeCode, abModeCode, cModeCode
    '前置码数组
    preModeCode = Array(0, 11, 13, 14, 19, 25, 28, 21, 22, 26)
    'AB模式数组
    abModeCode = Array(Array(13, 25, 19, 61, 35, 49, 47, 59, 55, 11), Array(39, 51, 27, 33, 29, 57, 5, 17, 9, 23))
    'C模式数组
    cModeCode = Array(114, 102, 108, 66, 92, 78, 80, 68, 72, 116)

    '获取输入的条码
    Dim inText As String
    inText = Range("$A$1").Text

    '将输入的EAN13码拆分为输入码数组
    ReDim inCode(0 To Len(inText) - 1)
    For i = 0 To Len(inText) - 1
        inCode(i) = Mid(inText, i + 1, 1)
    Next

    '计算校验位
    Dim checkSum As Integer
    checkSum = Get_EAN_CheckSum(inText)
    '将校验位压入数组
    inCode(Len(inText) - 1) = checkSum
    
    '要绘制的坐标位置
    Dim startX, startY As Integer
    startX = 3
    startY = 3
    
    '绘制码区边界
    Dim f, p, t, s As Integer
    f = Fill_EAN_Bounds(startX, startY)


    p = preModeCode(inCode(0))
    For i = 0 To 5
       t = IIf(p And (2 ^ (5 - i)), 1, 0)
       s = Fill_EAN_Lines(4 + startX + 7 * i, startY, abModeCode(t)(inCode(i + 1)))
    Next

    For i = 6 To 11
       s = Fill_EAN_Lines(9 + startX + 7 * i, startY, cModeCode(inCode(i + 1)))
    Next

End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
复制代码

montage64 1.png 2.png -geometry +10+10 -resize 50% 3.png
复制代码