programing

Excel VBA를 사용하여 코드 128 바코드 생성

elecom 2023. 8. 11. 21:32
반응형

Excel VBA를 사용하여 코드 128 바코드 생성

저는 VBA를 사용하여 엑셀에서 생성된 코드 128 바코드를 얻으려고 합니다.누군가가 VB 포럼을 통해 만들고 공유한 VBA 클래스(이후 Excel VBA와 함께 작동하도록 수정됨)를 찾았지만 작동하는 데 문제가 있습니다.

Excel 매크로 지원 스프레드시트에서 아래 코드를 사용하면 Code128_Str() 함수를 입력할 때 #VALUE 오류가 발생합니다.

코드를 제대로 디버깅하는 데 필요한 기술이 부족합니다.만약 이 스크립트가 수정될 수 있다면, 저는 동일한 작업을 시도하는 많은 사람들에게 매우 유용할 것이라고 생각합니다.해당 스크립트는 자유 글꼴을 사용하여 관련 코드 128 출력 바코드를 생성합니다.

참고 자료: http://www.barcodeman.com/info/c128.php3 (Font Download) http://www.vbforums.com/printthread.php?t=514742&pp=40&page=1 (코드가 있는 원본 포럼 스레드)

' ***    Made By Michael Ciurescu (CVMichael)   ***
'Modified by Paulo Cunha (pcunha) to work with char128.ttf on word or excel on 16/05/2011
'the font at in http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm


' References:
' http://www.barcodeman.com/info/c128.php3

Private Enum eCode128Type
    eCode128_CodeSetA = 1
    eCode128_CodeSetB = 2
    eCode128_CodeSetC = 3
End Enum

Private Type tCode
    ASet As String
    BSet As String
    CSet As String
    BarSpacePattern As String
End Type

Private CodeArr() As tCode

Private Sub Class_Initialize()
    ReDim CodeArr(106)

    AddEntry 0, " ", " ", "00", Chr(32)
    AddEntry 1, "!", "!", "01", Chr(33)
    AddEntry 2, """", """", "02", Chr(34)
    AddEntry 3, "#", "#", "03", Chr(35)
    AddEntry 4, "$", "$", "04", Chr(36)
    AddEntry 5, "%", "%", "05", Chr(37)
    AddEntry 6, "&", "&", "06", Chr(38)
    AddEntry 7, "'", "'", "07", Chr(39)
    AddEntry 8, "(", "(", "08", Chr(40)
    AddEntry 9, ")", ")", "09", Chr(41)
    AddEntry 10, "*", "*", "10", Chr(42)
    AddEntry 11, "+", "+", "11", Chr(43)
    AddEntry 12, ",", ",", "12", Chr(44)
    AddEntry 13, "-", "-", "13", Chr(45)
    AddEntry 14, ".", ".", "14", Chr(46)
    AddEntry 15, "/", "/", "15", Chr(47)
    AddEntry 16, "0", "0", "16", Chr(48)
    AddEntry 17, "1", "1", "17", Chr(49)
    AddEntry 18, "2", "2", "18", Chr(50)
    AddEntry 19, "3", "3", "19", Chr(51)
    AddEntry 20, "4", "4", "20", Chr(52)
    AddEntry 21, "5", "5", "21", Chr(53)
    AddEntry 22, "6", "6", "22", Chr(54)
    AddEntry 23, "7", "7", "23", Chr(55)
    AddEntry 24, "8", "8", "24", Chr(56)
    AddEntry 25, "9", "9", "25", Chr(57)
    AddEntry 26, ":", ":", "26", Chr(58)
    AddEntry 27, ";", ";", "27", Chr(59)
    AddEntry 28, "<", "<", "28", Chr(60)
    AddEntry 29, "=", "=", "29", Chr(61)
    AddEntry 30, ">", ">", "30", Chr(62)
    AddEntry 31, "?", "?", "31", Chr(63)
    AddEntry 32, "@", "@", "32", Chr(64)
    AddEntry 33, "A", "A", "33", Chr(65)
    AddEntry 34, "B", "B", "34", Chr(66)
    AddEntry 35, "C", "C", "35", Chr(67)
    AddEntry 36, "D", "D", "36", Chr(68)
    AddEntry 37, "E", "E", "37", Chr(69)
    AddEntry 38, "F", "F", "38", Chr(70)
    AddEntry 39, "G", "G", "39", Chr(71)
    AddEntry 40, "H", "H", "40", Chr(72)
    AddEntry 41, "I", "I", "41", Chr(73)
    AddEntry 42, "J", "J", "42", Chr(74)
    AddEntry 43, "K", "K", "43", Chr(75)
    AddEntry 44, "L", "L", "44", Chr(76)
    AddEntry 45, "M", "M", "45", Chr(77)
    AddEntry 46, "N", "N", "46", Chr(78)
    AddEntry 47, "O", "O", "47", Chr(79)
    AddEntry 48, "P", "P", "48", Chr(80)
    AddEntry 49, "Q", "Q", "49", Chr(81)
    AddEntry 50, "R", "R", "50", Chr(82)
    AddEntry 51, "S", "S", "51", Chr(83)
    AddEntry 52, "T", "T", "52", Chr(84)
    AddEntry 53, "U", "U", "53", Chr(85)
    AddEntry 54, "V", "V", "54", Chr(86)
    AddEntry 55, "W", "W", "55", Chr(87)
    AddEntry 56, "X", "X", "56", Chr(88)
    AddEntry 57, "Y", "Y", "57", Chr(89)
    AddEntry 58, "Z", "Z", "58", Chr(90)
    AddEntry 59, "[", "[", "59", Chr(91)
    AddEntry 60, "\", "\", "60", Chr(92)
    AddEntry 61, "]", "]", "61", Chr(93)
    AddEntry 62, "^", "^", "62", Chr(94)
    AddEntry 63, "_", "_", "63", Chr(95)
    AddEntry 64, Chr(0), "`", "64", Chr(96) ' Null
    AddEntry 65, Chr(1), "a", "65", Chr(97) ' SOH
    AddEntry 66, Chr(2), "b", "66", Chr(98) ' STX
    AddEntry 67, Chr(3), "c", "67", Chr(99) ' ETX
    AddEntry 68, Chr(4), "d", "68", Chr(100) ' EOT
    AddEntry 69, Chr(5), "e", "69", Chr(101) ' ENQ
    AddEntry 70, Chr(6), "f", "70", Chr(102) ' ACK
    AddEntry 71, Chr(7), "g", "71", Chr(103) ' BEL
    AddEntry 72, Chr(8), "h", "72", Chr(104) ' BS
    AddEntry 73, Chr(9), "i", "73", Chr(105) ' HT
    AddEntry 74, Chr(10), "j", "74", Chr(106) ' LF
    AddEntry 75, Chr(11), "k", "75", Chr(107) ' VT
    AddEntry 76, Chr(12), "l", "76", Chr(108) ' FF
    AddEntry 77, Chr(13), "m", "77", Chr(109) ' CR
    AddEntry 78, Chr(14), "n", "78", Chr(110) ' SO
    AddEntry 79, Chr(15), "o", "79", Chr(111) ' SI
    AddEntry 80, Chr(16), "p", "80", Chr(112) ' DLE
    AddEntry 81, Chr(17), "q", "81", Chr(113) ' DC1
    AddEntry 82, Chr(18), "r", "82", Chr(114) ' DC2
    AddEntry 83, Chr(19), "s", "83", Chr(115) ' DC3
    AddEntry 84, Chr(20), "t", "84", Chr(116) ' DC4
    AddEntry 85, Chr(21), "u", "85", Chr(117) ' NAK
    AddEntry 86, Chr(22), "v", "86", Chr(118) ' SYN
    AddEntry 87, Chr(23), "w", "87", Chr(119) ' ETB
    AddEntry 88, Chr(24), "x", "88", Chr(120) ' CAN
    AddEntry 89, Chr(25), "y", "89", Chr(121) ' EM
    AddEntry 90, Chr(26), "z", "90", Chr(122) ' SUB
    AddEntry 91, Chr(27), "{", "91", Chr(123) ' ESC
    AddEntry 92, Chr(28), "|", "92", Chr(124) ' FS
    AddEntry 93, Chr(29), "}", "93", Chr(125) ' GS
    AddEntry 94, Chr(30), "~", "94", Chr(126) ' RS
    AddEntry 95, Chr(31), Chr(127), "95", Chr(200) ' US, DEL
    AddEntry 96, "FNC 3", "FNC 3", "96", Chr(201)
    AddEntry 97, "FNC 2", "FNC 2", "97", Chr(202)
    AddEntry 98, "SHIFT", "SHIFT", "98", Chr(203)
    AddEntry 99, "CODE C", "CODE C", "99", Chr(204)
    AddEntry 100, "CODE B", "FNC 4", "CODE B", Chr(205)
    AddEntry 101, "FNC 4", "CODE A", "CODE A", Chr(206)
    AddEntry 102, "FNC 1", "FNC 1", "FNC 1", Chr(207)
    AddEntry 103, "Start A", "Start A", "Start A", Chr(208)
    AddEntry 104, "Start B", "Start B", "Start B", Chr(209)
    AddEntry 105, "Start C", "Start C", "Start C", Chr(210)
    AddEntry 106, "Stop", "Stop", "Stop", Chr(211)
End Sub

Private Sub AddEntry(ByVal Index As Integer, ASet As String, BSet As String, CSet As String, BarSpacePattern As String)
    With CodeArr(Index)
        .ASet = ASet
        .BSet = BSet
        .CSet = CSet
        .BarSpacePattern = Replace(BarSpacePattern, " ", "")
    End With
End Sub

Public Function Code128_Str(ByVal Str As String)
    Code128_Str = Replace(BuildStr(Str), " ", "")
End Function

Private Function BuildStr(ByVal Str As String) As String
    Dim SCode As eCode128Type, PrevSCode As eCode128Type
    Dim CurrChar As String, ArrIndex As Integer, CharIndex As Long
    Dim CheckDigit As Integer, CCodeIndex As Integer, TotalSum As Long

    SCode = eCode128_CodeSetB
    If Str Like "##*" Then SCode = eCode128_CodeSetC

    TotalSum = 0
    CharIndex = 1

    Select Case SCode
    Case eCode128_CodeSetA
        TotalSum = TotalSum + (103 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(208)
    Case eCode128_CodeSetB
        TotalSum = TotalSum + (104 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(209)
    Case eCode128_CodeSetC
        TotalSum = TotalSum + (105 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(210)
    End Select

    PrevSCode = SCode

    Do Until Len(Str) = 0
        If Str Like "####*" Then SCode = eCode128_CodeSetC

        If SCode = eCode128_CodeSetC And Mid(Str, 1, 2) Like "##" Then
            CurrChar = Mid(Str, 1, 2)
        Else
            CurrChar = Mid(Str, 1, 1)
        End If

        ArrIndex = GetCharIndex(CurrChar, SCode, True)

        If ArrIndex <> -1 Then
            If CodeArr(ArrIndex).BSet = CurrChar And ((SCode = eCode128_CodeSetC And CodeArr(ArrIndex).CSet <> CurrChar) Or (SCode = eCode128_CodeSetA And CodeArr(ArrIndex).ASet <> CurrChar)) Then
                SCode = eCode128_CodeSetB
            ElseIf CodeArr(ArrIndex).ASet = CurrChar And CodeArr(ArrIndex).BSet <> CurrChar Then
                SCode = eCode128_CodeSetA
            ElseIf CodeArr(ArrIndex).CSet = CurrChar Then
                SCode = eCode128_CodeSetC
            End If

            If PrevSCode <> SCode Then
                Select Case SCode
                Case eCode128_CodeSetA
                    CCodeIndex = GetCharIndex("CODE A", PrevSCode, False)
                Case eCode128_CodeSetB
                    CCodeIndex = GetCharIndex("CODE B", PrevSCode, False)
                Case eCode128_CodeSetC
                    CCodeIndex = GetCharIndex("CODE C", PrevSCode, False)
                End Select

                TotalSum = TotalSum + (CCodeIndex * CharIndex)
                BuildStr = Trim(BuildStr) & CodeArr(CCodeIndex).BarSpacePattern

                CharIndex = CharIndex + 1
                PrevSCode = SCode
            End If

            BuildStr = Trim(BuildStr) & CodeArr(ArrIndex).BarSpacePattern

            TotalSum = TotalSum + (ArrIndex * CharIndex)
            CharIndex = CharIndex + 1
        End If

        If SCode = eCode128_CodeSetC Then
            Str = Mid(Str, 3)
        Else
            Str = Mid(Str, 2)
        End If
    Loop

    CheckDigit = TotalSum Mod 103

    BuildStr = Trim(BuildStr) & CodeArr(CheckDigit).BarSpacePattern
    BuildStr = Trim(BuildStr) & Chr(211)
End Function

Private Function GetCharIndex(ByVal Char As String, ByVal CodeType As eCode128Type, ByVal Recurse As Boolean) As Integer
    Dim K As Long

    Select Case CodeType
    Case eCode128_CodeSetA
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).ASet Then Exit For
        Next K
    Case eCode128_CodeSetB
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).BSet Then Exit For
        Next K
    Case eCode128_CodeSetC
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).CSet Then Exit For
        Next K
    End Select

    If K = UBound(CodeArr) + 1 Then
        If Not Recurse Then
            GetCharIndex = -1
        Else
            Select Case CodeType
            Case eCode128_CodeSetA
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
            Case eCode128_CodeSetB
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
            Case eCode128_CodeSetC
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
            End Select

            If GetCharIndex = -1 Then
                Select Case CodeType
                Case eCode128_CodeSetA
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
                Case eCode128_CodeSetB
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
                Case eCode128_CodeSetC
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
                End Select
            End If
        End If
    Else
        GetCharIndex = K
    End If
End Function

Public Function Code128_GetWidth(ByVal Str As String, Optional ByVal BarWidth As Integer = 1) As Long
    Dim K As Long, Width As Long

    Str = Replace(Code128_Str(Str), " ", "")
    Debug.Print Str
    For K = 1 To Len(Str)
        Width = Width + Val(Mid(Str, K, 1))
    Next K

    Code128_GetWidth = Width * BarWidth + (28 * BarWidth)
End Function



Private Sub Class_Terminate()

End Sub

여기 사용 방법이 있습니다. 필요한 것은

  1. 모듈(Excel 스프레드시트에서 호출할 수 있는 UDF 기능 저장)
  2. 클래스 모듈(클래스 개체 저장)

모듈 여기서 Class1은 클래스 모듈의 이름입니다.

Public Function Code128_Str(ByVal Str As String) As String
Dim c As Class1
Set c = New Class1
Code128_Str = c.Code128_Str(Str)
End Function

클래스 모듈

' ***    Made By Michael Ciurescu (CVMichael)   ***
'Modified by Paulo Cunha (pcunha) to work with char128.ttf on word or excel on 16/05/2011
'the font at in http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm


' References:
' http://www.barcodeman.com/info/c128.php3

Private Enum eCode128Type
    eCode128_CodeSetA = 1
    eCode128_CodeSetB = 2
    eCode128_CodeSetC = 3
End Enum

Private Type tCode
    ASet As String
    BSet As String
    CSet As String
    BarSpacePattern As String
End Type

Private CodeArr() As tCode

Private Sub Class_Initialize()
    ReDim CodeArr(106)

    AddEntry 0, " ", " ", "00", Chr(32)
    AddEntry 1, "!", "!", "01", Chr(33)
    AddEntry 2, """", """", "02", Chr(34)
    AddEntry 3, "#", "#", "03", Chr(35)
    AddEntry 4, "$", "$", "04", Chr(36)
    AddEntry 5, "%", "%", "05", Chr(37)
    AddEntry 6, "&", "&", "06", Chr(38)
    AddEntry 7, "'", "'", "07", Chr(39)
    AddEntry 8, "(", "(", "08", Chr(40)
    AddEntry 9, ")", ")", "09", Chr(41)
    AddEntry 10, "*", "*", "10", Chr(42)
    AddEntry 11, "+", "+", "11", Chr(43)
    AddEntry 12, ",", ",", "12", Chr(44)
    AddEntry 13, "-", "-", "13", Chr(45)
    AddEntry 14, ".", ".", "14", Chr(46)
    AddEntry 15, "/", "/", "15", Chr(47)
    AddEntry 16, "0", "0", "16", Chr(48)
    AddEntry 17, "1", "1", "17", Chr(49)
    AddEntry 18, "2", "2", "18", Chr(50)
    AddEntry 19, "3", "3", "19", Chr(51)
    AddEntry 20, "4", "4", "20", Chr(52)
    AddEntry 21, "5", "5", "21", Chr(53)
    AddEntry 22, "6", "6", "22", Chr(54)
    AddEntry 23, "7", "7", "23", Chr(55)
    AddEntry 24, "8", "8", "24", Chr(56)
    AddEntry 25, "9", "9", "25", Chr(57)
    AddEntry 26, ":", ":", "26", Chr(58)
    AddEntry 27, ";", ";", "27", Chr(59)
    AddEntry 28, "<", "<", "28", Chr(60)
    AddEntry 29, "=", "=", "29", Chr(61)
    AddEntry 30, ">", ">", "30", Chr(62)
    AddEntry 31, "?", "?", "31", Chr(63)
    AddEntry 32, "@", "@", "32", Chr(64)
    AddEntry 33, "A", "A", "33", Chr(65)
    AddEntry 34, "B", "B", "34", Chr(66)
    AddEntry 35, "C", "C", "35", Chr(67)
    AddEntry 36, "D", "D", "36", Chr(68)
    AddEntry 37, "E", "E", "37", Chr(69)
    AddEntry 38, "F", "F", "38", Chr(70)
    AddEntry 39, "G", "G", "39", Chr(71)
    AddEntry 40, "H", "H", "40", Chr(72)
    AddEntry 41, "I", "I", "41", Chr(73)
    AddEntry 42, "J", "J", "42", Chr(74)
    AddEntry 43, "K", "K", "43", Chr(75)
    AddEntry 44, "L", "L", "44", Chr(76)
    AddEntry 45, "M", "M", "45", Chr(77)
    AddEntry 46, "N", "N", "46", Chr(78)
    AddEntry 47, "O", "O", "47", Chr(79)
    AddEntry 48, "P", "P", "48", Chr(80)
    AddEntry 49, "Q", "Q", "49", Chr(81)
    AddEntry 50, "R", "R", "50", Chr(82)
    AddEntry 51, "S", "S", "51", Chr(83)
    AddEntry 52, "T", "T", "52", Chr(84)
    AddEntry 53, "U", "U", "53", Chr(85)
    AddEntry 54, "V", "V", "54", Chr(86)
    AddEntry 55, "W", "W", "55", Chr(87)
    AddEntry 56, "X", "X", "56", Chr(88)
    AddEntry 57, "Y", "Y", "57", Chr(89)
    AddEntry 58, "Z", "Z", "58", Chr(90)
    AddEntry 59, "[", "[", "59", Chr(91)
    AddEntry 60, "\", "\", "60", Chr(92)
    AddEntry 61, "]", "]", "61", Chr(93)
    AddEntry 62, "^", "^", "62", Chr(94)
    AddEntry 63, "_", "_", "63", Chr(95)
    AddEntry 64, Chr(0), "`", "64", Chr(96) ' Null
    AddEntry 65, Chr(1), "a", "65", Chr(97) ' SOH
    AddEntry 66, Chr(2), "b", "66", Chr(98) ' STX
    AddEntry 67, Chr(3), "c", "67", Chr(99) ' ETX
    AddEntry 68, Chr(4), "d", "68", Chr(100) ' EOT
    AddEntry 69, Chr(5), "e", "69", Chr(101) ' ENQ
    AddEntry 70, Chr(6), "f", "70", Chr(102) ' ACK
    AddEntry 71, Chr(7), "g", "71", Chr(103) ' BEL
    AddEntry 72, Chr(8), "h", "72", Chr(104) ' BS
    AddEntry 73, Chr(9), "i", "73", Chr(105) ' HT
    AddEntry 74, Chr(10), "j", "74", Chr(106) ' LF
    AddEntry 75, Chr(11), "k", "75", Chr(107) ' VT
    AddEntry 76, Chr(12), "l", "76", Chr(108) ' FF
    AddEntry 77, Chr(13), "m", "77", Chr(109) ' CR
    AddEntry 78, Chr(14), "n", "78", Chr(110) ' SO
    AddEntry 79, Chr(15), "o", "79", Chr(111) ' SI
    AddEntry 80, Chr(16), "p", "80", Chr(112) ' DLE
    AddEntry 81, Chr(17), "q", "81", Chr(113) ' DC1
    AddEntry 82, Chr(18), "r", "82", Chr(114) ' DC2
    AddEntry 83, Chr(19), "s", "83", Chr(115) ' DC3
    AddEntry 84, Chr(20), "t", "84", Chr(116) ' DC4
    AddEntry 85, Chr(21), "u", "85", Chr(117) ' NAK
    AddEntry 86, Chr(22), "v", "86", Chr(118) ' SYN
    AddEntry 87, Chr(23), "w", "87", Chr(119) ' ETB
    AddEntry 88, Chr(24), "x", "88", Chr(120) ' CAN
    AddEntry 89, Chr(25), "y", "89", Chr(121) ' EM
    AddEntry 90, Chr(26), "z", "90", Chr(122) ' SUB
    AddEntry 91, Chr(27), "{", "91", Chr(123) ' ESC
    AddEntry 92, Chr(28), "|", "92", Chr(124) ' FS
    AddEntry 93, Chr(29), "}", "93", Chr(125) ' GS
    AddEntry 94, Chr(30), "~", "94", Chr(126) ' RS
    AddEntry 95, Chr(31), Chr(127), "95", Chr(200) ' US, DEL
    AddEntry 96, "FNC 3", "FNC 3", "96", Chr(201)
    AddEntry 97, "FNC 2", "FNC 2", "97", Chr(202)
    AddEntry 98, "SHIFT", "SHIFT", "98", Chr(203)
    AddEntry 99, "CODE C", "CODE C", "99", Chr(204)
    AddEntry 100, "CODE B", "FNC 4", "CODE B", Chr(205)
    AddEntry 101, "FNC 4", "CODE A", "CODE A", Chr(206)
    AddEntry 102, "FNC 1", "FNC 1", "FNC 1", Chr(207)
    AddEntry 103, "Start A", "Start A", "Start A", Chr(208)
    AddEntry 104, "Start B", "Start B", "Start B", Chr(209)
    AddEntry 105, "Start C", "Start C", "Start C", Chr(210)
    AddEntry 106, "Stop", "Stop", "Stop", Chr(211)
End Sub

Private Sub AddEntry(ByVal Index As Integer, ASet As String, BSet As String, CSet As String, BarSpacePattern As String)
    With CodeArr(Index)
        .ASet = ASet
        .BSet = BSet
        .CSet = CSet
        .BarSpacePattern = Replace(BarSpacePattern, " ", "")
    End With
End Sub

Public Function Code128_Str(ByVal Str As String)
    Code128_Str = Replace(BuildStr(Str), " ", "")
End Function

Private Function BuildStr(ByVal Str As String) As String
    Dim SCode As eCode128Type, PrevSCode As eCode128Type
    Dim CurrChar As String, ArrIndex As Integer, CharIndex As Long
    Dim CheckDigit As Integer, CCodeIndex As Integer, TotalSum As Long

    SCode = eCode128_CodeSetB
    If Str Like "##*" Then SCode = eCode128_CodeSetC

    TotalSum = 0
    CharIndex = 1

    Select Case SCode
    Case eCode128_CodeSetA
        TotalSum = TotalSum + (103 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(208)
    Case eCode128_CodeSetB
        TotalSum = TotalSum + (104 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(209)
    Case eCode128_CodeSetC
        TotalSum = TotalSum + (105 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(210)
    End Select

    PrevSCode = SCode

    Do Until Len(Str) = 0
        If Str Like "####*" Then SCode = eCode128_CodeSetC

        If SCode = eCode128_CodeSetC And Mid(Str, 1, 2) Like "##" Then
            CurrChar = Mid(Str, 1, 2)
        Else
            CurrChar = Mid(Str, 1, 1)
        End If

        ArrIndex = GetCharIndex(CurrChar, SCode, True)

        If ArrIndex <> -1 Then
            If CodeArr(ArrIndex).BSet = CurrChar And ((SCode = eCode128_CodeSetC And CodeArr(ArrIndex).CSet <> CurrChar) Or (SCode = eCode128_CodeSetA And CodeArr(ArrIndex).ASet <> CurrChar)) Then
                SCode = eCode128_CodeSetB
            ElseIf CodeArr(ArrIndex).ASet = CurrChar And CodeArr(ArrIndex).BSet <> CurrChar Then
                SCode = eCode128_CodeSetA
            ElseIf CodeArr(ArrIndex).CSet = CurrChar Then
                SCode = eCode128_CodeSetC
            End If

            If PrevSCode <> SCode Then
                Select Case SCode
                Case eCode128_CodeSetA
                    CCodeIndex = GetCharIndex("CODE A", PrevSCode, False)
                Case eCode128_CodeSetB
                    CCodeIndex = GetCharIndex("CODE B", PrevSCode, False)
                Case eCode128_CodeSetC
                    CCodeIndex = GetCharIndex("CODE C", PrevSCode, False)
                End Select

                TotalSum = TotalSum + (CCodeIndex * CharIndex)
                BuildStr = Trim(BuildStr) & CodeArr(CCodeIndex).BarSpacePattern

                CharIndex = CharIndex + 1
                PrevSCode = SCode
            End If

            BuildStr = Trim(BuildStr) & CodeArr(ArrIndex).BarSpacePattern

            TotalSum = TotalSum + (ArrIndex * CharIndex)
            CharIndex = CharIndex + 1
        End If

        If SCode = eCode128_CodeSetC Then
            Str = Mid(Str, 3)
        Else
            Str = Mid(Str, 2)
        End If
    Loop

    CheckDigit = TotalSum Mod 103

    BuildStr = Trim(BuildStr) & CodeArr(CheckDigit).BarSpacePattern
    BuildStr = Trim(BuildStr) & Chr(211)
End Function

Private Function GetCharIndex(ByVal Char As String, ByVal CodeType As eCode128Type, ByVal Recurse As Boolean) As Integer
    Dim K As Long

    Select Case CodeType
    Case eCode128_CodeSetA
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).ASet Then Exit For
        Next K
    Case eCode128_CodeSetB
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).BSet Then Exit For
        Next K
    Case eCode128_CodeSetC
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).CSet Then Exit For
        Next K
    End Select

    If K = UBound(CodeArr) + 1 Then
        If Not Recurse Then
            GetCharIndex = -1
        Else
            Select Case CodeType
            Case eCode128_CodeSetA
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
            Case eCode128_CodeSetB
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
            Case eCode128_CodeSetC
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
            End Select

            If GetCharIndex = -1 Then
                Select Case CodeType
                Case eCode128_CodeSetA
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
                Case eCode128_CodeSetB
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
                Case eCode128_CodeSetC
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
                End Select
            End If
        End If
    Else
        GetCharIndex = K
    End If
End Function

Public Function Code128_GetWidth(ByVal Str As String, Optional ByVal BarWidth As Integer = 1) As Long
    Dim K As Long, Width As Long

    Str = Replace(Code128_Str(Str), " ", "")
    Debug.Print Str
    For K = 1 To Len(Str)
        Width = Width + Val(Mid(Str, K, 1))
    Next K

    Code128_GetWidth = Width * BarWidth + (28 * BarWidth)
End Function



Private Sub Class_Terminate()

End Sub

그런 다음 스프레드시트의 모든 셀에서 다음과 같이 호출할 수 있습니다.=Code128_Str("TESTING")또는=Code128_Str(A1)

래리의 코드는 훌륭하지만, 저는 단 한 가지 작은 문제만 발견했습니다.(저는 그의 대답에 대해 논평했을 것이지만 저는 평판이 충분하지 않습니다.)이중 0을 인코딩할 때 문제가 있었습니다.예를 들어 "1200"입니다."00"은 공간을 의미합니다.코드에는 공간을 "잘라내거나" 공간을 "바꾸는" 수많은 장소가 있습니다.제가 "1200"을 인코딩하려고 하면 바코드는 "12"만 됩니다.이 문제를 해결하기 위해 다음과 같이 해당 "트림"과 "교체"를 제거했습니다.아래 코드는 클래스 모듈만 해당됩니다.모듈 코드는 래리의 게시물을 참고하시기 바랍니다.

클래스 모듈

' ***    Made By Michael Ciurescu (CVMichael)   ***
'Modified by Paulo Cunha (pcunha) to work with char128.ttf on word or excel on 16/05/2011
'the font at in http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm
' References:
' http://www.barcodeman.com/info/c128.php3

Private Enum eCode128Type
    eCode128_CodeSetA = 1
    eCode128_CodeSetB = 2
    eCode128_CodeSetC = 3
End Enum

Private Type tCode
    ASet As String
    BSet As String
    CSet As String
    BarSpacePattern As String
End Type

Private CodeArr() As tCode

Private Sub Class_Initialize()
    ReDim CodeArr(106)

    AddEntry 0, " ", " ", "00", Chr(32)
    AddEntry 1, "!", "!", "01", Chr(33)
    AddEntry 2, """", """", "02", Chr(34)
    AddEntry 3, "#", "#", "03", Chr(35)
    AddEntry 4, "$", "$", "04", Chr(36)
    AddEntry 5, "%", "%", "05", Chr(37)
    AddEntry 6, "&", "&", "06", Chr(38)
    AddEntry 7, "'", "'", "07", Chr(39)
    AddEntry 8, "(", "(", "08", Chr(40)
    AddEntry 9, ")", ")", "09", Chr(41)
    AddEntry 10, "*", "*", "10", Chr(42)
    AddEntry 11, "+", "+", "11", Chr(43)
    AddEntry 12, ",", ",", "12", Chr(44)
    AddEntry 13, "-", "-", "13", Chr(45)
    AddEntry 14, ".", ".", "14", Chr(46)
    AddEntry 15, "/", "/", "15", Chr(47)
    AddEntry 16, "0", "0", "16", Chr(48)
    AddEntry 17, "1", "1", "17", Chr(49)
    AddEntry 18, "2", "2", "18", Chr(50)
    AddEntry 19, "3", "3", "19", Chr(51)
    AddEntry 20, "4", "4", "20", Chr(52)
    AddEntry 21, "5", "5", "21", Chr(53)
    AddEntry 22, "6", "6", "22", Chr(54)
    AddEntry 23, "7", "7", "23", Chr(55)
    AddEntry 24, "8", "8", "24", Chr(56)
    AddEntry 25, "9", "9", "25", Chr(57)
    AddEntry 26, ":", ":", "26", Chr(58)
    AddEntry 27, ";", ";", "27", Chr(59)
    AddEntry 28, "<", "<", "28", Chr(60)
    AddEntry 29, "=", "=", "29", Chr(61)
    AddEntry 30, ">", ">", "30", Chr(62)
    AddEntry 31, "?", "?", "31", Chr(63)
    AddEntry 32, "@", "@", "32", Chr(64)
    AddEntry 33, "A", "A", "33", Chr(65)
    AddEntry 34, "B", "B", "34", Chr(66)
    AddEntry 35, "C", "C", "35", Chr(67)
    AddEntry 36, "D", "D", "36", Chr(68)
    AddEntry 37, "E", "E", "37", Chr(69)
    AddEntry 38, "F", "F", "38", Chr(70)
    AddEntry 39, "G", "G", "39", Chr(71)
    AddEntry 40, "H", "H", "40", Chr(72)
    AddEntry 41, "I", "I", "41", Chr(73)
    AddEntry 42, "J", "J", "42", Chr(74)
    AddEntry 43, "K", "K", "43", Chr(75)
    AddEntry 44, "L", "L", "44", Chr(76)
    AddEntry 45, "M", "M", "45", Chr(77)
    AddEntry 46, "N", "N", "46", Chr(78)
    AddEntry 47, "O", "O", "47", Chr(79)
    AddEntry 48, "P", "P", "48", Chr(80)
    AddEntry 49, "Q", "Q", "49", Chr(81)
    AddEntry 50, "R", "R", "50", Chr(82)
    AddEntry 51, "S", "S", "51", Chr(83)
    AddEntry 52, "T", "T", "52", Chr(84)
    AddEntry 53, "U", "U", "53", Chr(85)
    AddEntry 54, "V", "V", "54", Chr(86)
    AddEntry 55, "W", "W", "55", Chr(87)
    AddEntry 56, "X", "X", "56", Chr(88)
    AddEntry 57, "Y", "Y", "57", Chr(89)
    AddEntry 58, "Z", "Z", "58", Chr(90)
    AddEntry 59, "[", "[", "59", Chr(91)
    AddEntry 60, "\", "\", "60", Chr(92)
    AddEntry 61, "]", "]", "61", Chr(93)
    AddEntry 62, "^", "^", "62", Chr(94)
    AddEntry 63, "_", "_", "63", Chr(95)
    AddEntry 64, Chr(0), "`", "64", Chr(96) ' Null
    AddEntry 65, Chr(1), "a", "65", Chr(97) ' SOH
    AddEntry 66, Chr(2), "b", "66", Chr(98) ' STX
    AddEntry 67, Chr(3), "c", "67", Chr(99) ' ETX
    AddEntry 68, Chr(4), "d", "68", Chr(100) ' EOT
    AddEntry 69, Chr(5), "e", "69", Chr(101) ' ENQ
    AddEntry 70, Chr(6), "f", "70", Chr(102) ' ACK
    AddEntry 71, Chr(7), "g", "71", Chr(103) ' BEL
    AddEntry 72, Chr(8), "h", "72", Chr(104) ' BS
    AddEntry 73, Chr(9), "i", "73", Chr(105) ' HT
    AddEntry 74, Chr(10), "j", "74", Chr(106) ' LF
    AddEntry 75, Chr(11), "k", "75", Chr(107) ' VT
    AddEntry 76, Chr(12), "l", "76", Chr(108) ' FF
    AddEntry 77, Chr(13), "m", "77", Chr(109) ' CR
    AddEntry 78, Chr(14), "n", "78", Chr(110) ' SO
    AddEntry 79, Chr(15), "o", "79", Chr(111) ' SI
    AddEntry 80, Chr(16), "p", "80", Chr(112) ' DLE
    AddEntry 81, Chr(17), "q", "81", Chr(113) ' DC1
    AddEntry 82, Chr(18), "r", "82", Chr(114) ' DC2
    AddEntry 83, Chr(19), "s", "83", Chr(115) ' DC3
    AddEntry 84, Chr(20), "t", "84", Chr(116) ' DC4
    AddEntry 85, Chr(21), "u", "85", Chr(117) ' NAK
    AddEntry 86, Chr(22), "v", "86", Chr(118) ' SYN
    AddEntry 87, Chr(23), "w", "87", Chr(119) ' ETB
    AddEntry 88, Chr(24), "x", "88", Chr(120) ' CAN
    AddEntry 89, Chr(25), "y", "89", Chr(121) ' EM
    AddEntry 90, Chr(26), "z", "90", Chr(122) ' SUB
    AddEntry 91, Chr(27), "{", "91", Chr(123) ' ESC
    AddEntry 92, Chr(28), "|", "92", Chr(124) ' FS
    AddEntry 93, Chr(29), "}", "93", Chr(125) ' GS
    AddEntry 94, Chr(30), "~", "94", Chr(126) ' RS
    AddEntry 95, Chr(31), Chr(127), "95", Chr(200) ' US, DEL
    AddEntry 96, "FNC 3", "FNC 3", "96", Chr(201)
    AddEntry 97, "FNC 2", "FNC 2", "97", Chr(202)
    AddEntry 98, "SHIFT", "SHIFT", "98", Chr(203)
    AddEntry 99, "CODE C", "CODE C", "99", Chr(204)
    AddEntry 100, "CODE B", "FNC 4", "CODE B", Chr(205)
    AddEntry 101, "FNC 4", "CODE A", "CODE A", Chr(206)
    AddEntry 102, "FNC 1", "FNC 1", "FNC 1", Chr(207)
    AddEntry 103, "Start A", "Start A", "Start A", Chr(208)
    AddEntry 104, "Start B", "Start B", "Start B", Chr(209)
    AddEntry 105, "Start C", "Start C", "Start C", Chr(210)
    AddEntry 106, "Stop", "Stop", "Stop", Chr(211)
End Sub

Private Sub AddEntry(ByVal Index As Integer, ASet As String, BSet As String, CSet As String, BarSpacePattern As String)
    With CodeArr(Index)
        .ASet = ASet
        .BSet = BSet
        .CSet = CSet
        '.BarSpacePattern = Replace(BarSpacePattern, " ", "")
        .BarSpacePattern = BarSpacePattern
    End With
End Sub

Public Function Code128_Str(ByVal Str As String)
    'Code128_Str = Replace(BuildStr(Str), " ", "")
    Code128_Str = BuildStr(Str)
End Function

Private Function BuildStr(ByVal Str As String) As String
    Dim SCode As eCode128Type, PrevSCode As eCode128Type
    Dim CurrChar As String, ArrIndex As Integer, CharIndex As Long
    Dim CheckDigit As Integer, CCodeIndex As Integer, TotalSum As Long

    SCode = eCode128_CodeSetB
    If Str Like "##*" Then SCode = eCode128_CodeSetC

    TotalSum = 0
    CharIndex = 1

    Select Case SCode
    Case eCode128_CodeSetA
        TotalSum = TotalSum + (103 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(208)
    Case eCode128_CodeSetB
        TotalSum = TotalSum + (104 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(209)
    Case eCode128_CodeSetC
        TotalSum = TotalSum + (105 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(210)
    End Select

    PrevSCode = SCode

    Do Until Len(Str) = 0
        If Str Like "####*" Then SCode = eCode128_CodeSetC

        If SCode = eCode128_CodeSetC And Mid(Str, 1, 2) Like "##" Then
            CurrChar = Mid(Str, 1, 2)
        Else
            CurrChar = Mid(Str, 1, 1)
        End If

        ArrIndex = GetCharIndex(CurrChar, SCode, True)

        If ArrIndex <> -1 Then
            If CodeArr(ArrIndex).BSet = CurrChar And ((SCode = eCode128_CodeSetC And CodeArr(ArrIndex).CSet <> CurrChar) Or (SCode = eCode128_CodeSetA And CodeArr(ArrIndex).ASet <> CurrChar)) Then
                SCode = eCode128_CodeSetB
            ElseIf CodeArr(ArrIndex).ASet = CurrChar And CodeArr(ArrIndex).BSet <> CurrChar Then
                SCode = eCode128_CodeSetA
            ElseIf CodeArr(ArrIndex).CSet = CurrChar Then
                SCode = eCode128_CodeSetC
            End If

            If PrevSCode <> SCode Then
                Select Case SCode
                Case eCode128_CodeSetA
                    CCodeIndex = GetCharIndex("CODE A", PrevSCode, False)
                Case eCode128_CodeSetB
                    CCodeIndex = GetCharIndex("CODE B", PrevSCode, False)
                Case eCode128_CodeSetC
                    CCodeIndex = GetCharIndex("CODE C", PrevSCode, False)
                End Select

                TotalSum = TotalSum + (CCodeIndex * CharIndex)
                'BuildStr = Trim(BuildStr) & CodeArr(CCodeIndex).BarSpacePattern
                BuildStr = BuildStr & CodeArr(CCodeIndex).BarSpacePattern

                CharIndex = CharIndex + 1
                PrevSCode = SCode
            End If

            'BuildStr = Trim(BuildStr) & CodeArr(ArrIndex).BarSpacePattern
            BuildStr = BuildStr & CodeArr(ArrIndex).BarSpacePattern

            TotalSum = TotalSum + (ArrIndex * CharIndex)
            CharIndex = CharIndex + 1
        End If

        If SCode = eCode128_CodeSetC Then
            Str = Mid(Str, 3)
        Else
            Str = Mid(Str, 2)
        End If
    Loop

    CheckDigit = TotalSum Mod 103

    'BuildStr = Trim(BuildStr) & CodeArr(CheckDigit).BarSpacePattern
    BuildStr = BuildStr & CodeArr(CheckDigit).BarSpacePattern
    'BuildStr = Trim(BuildStr) & Chr(211)
    BuildStr = BuildStr & Chr(211)
End Function

Private Function GetCharIndex(ByVal Char As String, ByVal CodeType As eCode128Type, ByVal Recurse As Boolean) As Integer
    Dim K As Long

    Select Case CodeType
    Case eCode128_CodeSetA
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).ASet Then Exit For
        Next K
    Case eCode128_CodeSetB
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).BSet Then Exit For
        Next K
    Case eCode128_CodeSetC
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).CSet Then Exit For
        Next K
    End Select

    If K = UBound(CodeArr) + 1 Then
        If Not Recurse Then
            GetCharIndex = -1
        Else
            Select Case CodeType
            Case eCode128_CodeSetA
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
            Case eCode128_CodeSetB
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
            Case eCode128_CodeSetC
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
            End Select

            If GetCharIndex = -1 Then
                Select Case CodeType
                Case eCode128_CodeSetA
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
                Case eCode128_CodeSetB
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
                Case eCode128_CodeSetC
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
                End Select
            End If
        End If
    Else
        GetCharIndex = K
    End If
End Function

Public Function Code128_GetWidth(ByVal Str As String, Optional ByVal BarWidth As Integer = 1) As Long
    Dim K As Long, Width As Long

    Str = Replace(Code128_Str(Str), " ", "")
    Debug.Print Str
    For K = 1 To Len(Str)
        Width = Width + Val(Mid(Str, K, 1))
    Next K

    Code128_GetWidth = Width * BarWidth + (28 * BarWidth)
End Function



Private Sub Class_Terminate()

End Sub

언급URL : https://stackoverflow.com/questions/13909248/generating-code-128-barcodes-using-excel-vba

반응형

'programing' 카테고리의 다른 글

구성 관리자.앱 설정이 null이 됩니까?  (0) 2023.08.11
jquery를 사용하여 div에서 스타일 속성 추가 및 제거  (0) 2023.08.11
스위치 문의 사례 순서가 성능에 영향을 미칩니까?  (0) 2023.08.11
파이썬에 'string.split()'의 생성기 버전이 있습니까?  (0) 2023.08.11
검사 제약 조건에서 날짜 사용, Oracle  (0) 2023.08.11

'programing'의 다른글

  • 현재글Excel VBA를 사용하여 코드 128 바코드 생성

관련글

댓글

티스토리툴바