BarCode 算法 VB类库 2

最新推荐文章于 2023-01-20 17:47:29 发布

dnvodcwan

最新推荐文章于 2023-01-20 17:47:29 发布

阅读量773

点赞数

分类专栏： Bar Code 文章标签： vb 算法 string integer function c

本文链接：https://blog.csdn.net/dnvodcwan/article/details/4804131

版权

Bar Code 专栏收录该内容

1 篇文章 0 订阅

订阅专栏

Option Explicit
Public Function ascii2Char(strInput As String) As String
Dim i As Integer
Dim strTemp As String
Dim nPos As Integer
Dim nValue As Integer

i = 1
nPos = InStr(i, strInput, "&#", vbTextCompare)
While (nPos > 0)
    ascii2Char = ascii2Char + Left(strInput, nPos - 1)
    strInput = Right(strInput, Len(strInput) - nPos + 1)
    i = 3
    strTemp = ""
    While (i <= Len(strInput) And IsNumeric(Mid(strInput, i, 1)) And Len(strTemp) < 3)
        strTemp = strTemp + Mid(strInput, i, 1)
        i = i + 1
    Wend
    nValue = 0
    If (strTemp <> "") Then nValue = Val(strTemp)
    If (nValue >= 0 And nValue < 128) Then
        ascii2Char = ascii2Char + Chr(nValue)
    ElseIf (nValue > 127 And nValue < 256) Then
        ascii2Char = ascii2Char + ChrW(nValue)
    Else
        ascii2Char = ascii2Char + Left(strInput, i - 1)
    End If
    If (i <= Len(strInput) And Mid(strInput, i, 1) = ";") Then
        i = i + 1
    End If
    strInput = Right(strInput, Len(strInput) - i + 1)
    nPos = InStr(1, strInput, "&#", vbTextCompare)
Wend
If (Len(strInput) > 0) Then
    ascii2Char = ascii2Char + strInput
End If
End Function

Public Function Code39(strToEncode As String) As String
Dim i As Integer
Dim charSet As String
Dim charToEncode As String
Dim charPos As Integer
Dim mappingSet As String

charSet = "0123456789.+-/ $%ABCDEFGHIJKLMNOPQRSTUVWXYZ"
mappingSet = "0123456789.+-/#$%ABCDEFGHIJKLMNOPQRSTUVWXYZ"

strToEncode = ascii2Char(strToEncode)
For i = 1 To Len(strToEncode)
    charPos = InStr(1, charSet, Mid(strToEncode, i, 1), 0)
    If charPos > 0 Then
        Code39 = Code39 + Mid(mappingSet, charPos, 1)
    End If
Next i
Code39 = "*" + Code39 + "*"
End Function

Public Function USSCode39(strToEncode As String) As String
Dim i As Integer
Dim charSet As String
Dim charToEncode As String
Dim charPos As Integer
Dim checkDigit As String
Dim mappingSet As String

charSet = "0123456789.+-/ $%ABCDEFGHIJKLMNOPQRSTUVWXYZ"
mappingSet = "0123456789.+-/#$%ABCDEFGHIJKLMNOPQRSTUVWXYZ"

strToEncode = ascii2Char(strToEncode)
For i = 1 To Len(strToEncode)
    charPos = InStr(1, charSet, Mid(strToEncode, i, 1), 0)
    If charPos > 0 Then
        USSCode39 = USSCode39 + Mid(mappingSet, charPos, 1)
    End If
Next i
checkDigit = MOD10(USSCode39)
USSCode39 = USSCode39 + checkDigit
USSCode39 = "*" + USSCode39 + "*"
End Function

Public Function UPCE(ByVal strToEncode As String) As String
    Dim checkDigit As String
    Dim strMod As String
    Dim strUPCA As String
    Dim i As Integer
    Dim charSet As String
    Dim strSupplement As String
    Dim charPos As Integer

    charSet = "0123456789|"
    strToEncode = maskfilter(strToEncode, charSet)
    charPos = InStr(1, strToEncode, "|", 0)

    If charPos > 0 Then
        strSupplement = UPC25SUPP(Right(strToEncode, Len(strToEncode) - charPos))
        strToEncode = Left(strToEncode, charPos - 1)
    End If
    If Len(strToEncode) < 6 Then
        While Len(strToEncode) < 6
            strToEncode = strToEncode + "0"
        Wend
    ElseIf Len(strToEncode) > 6 Then
        strToEncode = Left(strToEncode, 6)
    End If
    strToEncode = "0" + strToEncode

    strUPCA = Upce2upca(strToEncode)
    checkDigit = UPCchecksum(strUPCA)
    Select Case checkDigit
        Case 0: strMod = "BBBAAA"
        Case 1: strMod = "BBABAA"
        Case 2: strMod = "BBAABA"
        Case 3: strMod = "BBAAAB"
        Case 4: strMod = "BABBAA"
        Case 5: strMod = "BAABBA"
        Case 6: strMod = "BAAABB"
        Case 7: strMod = "BABABA"
        Case 8: strMod = "BABAAB"
        Case 9: strMod = "BAABAB"
    End Select

    UPCE = "["
    For i = 2 To 7
        If Mid(strMod, i - 1, 1) = "A" Then
            UPCE = UPCE + convertSetAText(Mid(strToEncode, i, 1))
        ElseIf Mid(strMod, i - 1, 1) = "B" Then
            UPCE = UPCE + convertSetBText(Mid(strToEncode, i, 1))
        End If
    Next i
    UPCE = textOnly("0") + UPCE + "'" + textOnly(checkDigit) + " " + strSupplement
End Function
Public Function EAN13(strToEncode As String) As String
Dim i As Integer
Dim checkDigit As String
Dim charToEncode As String
Dim strMod As String
Dim charSet As String
Dim strSupplement As String
Dim charPos As Integer

charSet = "0123456789|"
strToEncode = maskfilter(strToEncode, charSet)
charPos = InStr(1, strToEncode, "|", 0)

If charPos > 0 Then
    strSupplement = UPC25SUPP(Right(strToEncode, Len(strToEncode) - charPos))
    strToEncode = Left(strToEncode, charPos - 1)
End If
If Len(strToEncode) < 12 Then
    While Len(strToEncode) < 12
        strToEncode = strToEncode + "0"
    Wend
ElseIf Len(strToEncode) > 12 Then
    strToEncode = Left(strToEncode, 12)
End If

Select Case Mid(strToEncode, 1, 1)
Case 0: strMod = "AAAAAA"
Case 1: strMod = "AABABB"
Case 2: strMod = "AABBAB"
Case 3: strMod = "AABBBA"
Case 4: strMod = "ABAABB"
Case 5: strMod = "ABBAAB"
Case 6: strMod = "ABBBAA"
Case 7: strMod = "ABABAB"
Case 8: strMod = "ABABBA"
Case 9: strMod = "ABBABA"
End Select

EAN13 = textOnly(Mid(strToEncode, 1, 1)) + "["

For i = 2 To 7
    If Mid(strMod, i - 1, 1) = "A" Then
        EAN13 = EAN13 + convertSetAText(Mid(strToEncode, i, 1))
    ElseIf Mid(strMod, i - 1, 1) = "B" Then
        EAN13 = EAN13 + convertSetBText(Mid(strToEncode, i, 1))
    End If
Next i
EAN13 = EAN13 + "|"
For i = 8 To 12
    EAN13 = EAN13 + convertSetCText(Mid(strToEncode, i, 1))
Next i
checkDigit = UPCchecksum(strToEncode)
EAN13 = EAN13 + convertSetCText(checkDigit) + "]" + " " + strSupplement
End Function
Public Function EAN8(strToEncode As String) As String
Dim i As Integer
Dim charToEncode As String
Dim charSet As String
Dim strSupplement As String
Dim charPos As Integer

charSet = "0123456789|"
strToEncode = maskfilter(strToEncode, charSet)
charPos = InStr(1, strToEncode, "|", 0)

If charPos > 0 Then
    strSupplement = UPC25SUPP(Right(strToEncode, Len(strToEncode) - charPos))
    strToEncode = Left(strToEncode, charPos - 1)
End If
If Len(strToEncode) < 7 Then
    While Len(strToEncode) < 7
        strToEncode = strToEncode + "0"
    Wend
ElseIf Len(strToEncode) > 7 Then
    strToEncode = Left(strToEncode, 7)
End If

For i = 1 To 4
EAN8 = EAN8 + convertSetAText(Mid(strToEncode, i, 1))
Next i
EAN8 = EAN8 + "|"
For i = 5 To 7
EAN8 = EAN8 + convertSetCText(Mid(strToEncode, i, 1))
Next i
EAN8 = "[" + EAN8 + convertSetCText(UPCchecksum(strToEncode)) + "]" + " " + strSupplement
End Function

Public Function Code39Mod43(strToEncode As String) As String
Dim charSet As String
Dim mappingSet As String
Dim i As Integer
Dim checkSum As Integer
Dim charPos As Integer

charSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%"
mappingSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-.#$/+%"
strToEncode = ascii2Char(strToEncode)

For i = 1 To Len(strToEncode)
    charPos = InStr(1, charSet, Mid(strToEncode, i, 1), vbBinaryCompare)
    checkSum = checkSum + (charPos - 1)
    Code39Mod43 = Code39Mod43 + Mid(mappingSet, charPos, 1)
Next i
checkSum = checkSum Mod 43
Code39Mod43 = "*" + Code39Mod43 + Mid(mappingSet, checkSum + 1, 1) + "*"
End Function

Public Function UPCA(strToEncode As String) As String
Dim checkDigit As String
Dim i As Integer
Dim charSet As String
Dim strSupplement As String
Dim charPos As Integer

charSet = "0123456789|"
strToEncode = maskfilter(strToEncode, charSet)
charPos = InStr(1, strToEncode, "|", 0)

If charPos > 0 Then
strSupplement = UPC25SUPP(Right(strToEncode, Len(strToEncode) - charPos))
strToEncode = Left(strToEncode, charPos - 1)
End If

If Len(strToEncode) < 11 Then
    While Len(strToEncode) < 11
        strToEncode = strToEncode + "0"
    Wend
ElseIf Len(strToEncode) > 11 Then
    strToEncode = Left(strToEncode, 11)
End If

UPCA = textOnly(Mid(strToEncode, 1, 1)) + "[" + convertSetANoText(Mid(strToEncode, 1, 1))

For i = 1 To 5
UPCA = UPCA + convertSetAText(Mid(strToEncode, (1 + i), 1))
Next i

UPCA = UPCA + "|"
For i = 1 To 5
UPCA = UPCA + convertSetCText(Mid(strToEncode, (6 + i), 1))
Next i
checkDigit = UPCchecksum(strToEncode)
UPCA = UPCA + convertSetCNoText(checkDigit) + "]" + textOnly(checkDigit)
UPCA = UPCA + " " + strSupplement
End Function

Function textOnly(ch As String) As String
Select Case ch
Case "1": textOnly = Chr(225)
Case "2": textOnly = Chr(226)
Case "3": textOnly = Chr(227)
Case "4": textOnly = Chr(228)
Case "5": textOnly = Chr(229)
Case "6": textOnly = Chr(230)
Case "7": textOnly = Chr(231)
Case "8": textOnly = Chr(232)
Case "9": textOnly = Chr(233)
Case "0": textOnly = Chr(224)
End Select
End Function

Function convertSetAText(ch As String) As String
Select Case ch
Case "1": convertSetAText = "1"
Case "2": convertSetAText = "2"
Case "3": convertSetAText = "3"
Case "4": convertSetAText = "4"
Case "5": convertSetAText = "5"
Case "6": convertSetAText = "6"
Case "7": convertSetAText = "7"
Case "8": convertSetAText = "8"
Case "9": convertSetAText = "9"
Case "0": convertSetAText = "0"
End Select
End Function

Function convertSetANoText(ch As String) As String
Select Case ch
Case "1": convertSetANoText = "!"
Case "2": convertSetANoText = "@"
Case "3": convertSetANoText = "#"
Case "4": convertSetANoText = "$"
Case "5": convertSetANoText = "%"
Case "6": convertSetANoText = "^"
Case "7": convertSetANoText = "&"
Case "8": convertSetANoText = "*"
Case "9": convertSetANoText = "("
Case "0": convertSetANoText = ")"
End Select
End Function

Function convertSetCText(ch As String) As String
Select Case ch
Case "1": convertSetCText = "A"
Case "2": convertSetCText = "S"
Case "3": convertSetCText = "D"
Case "4": convertSetCText = "F"
Case "5": convertSetCText = "G"
Case "6": convertSetCText = "H"
Case "7": convertSetCText = "J"
Case "8": convertSetCText = "K"
Case "9": convertSetCText = "L"
Case "0": convertSetCText = ":"
End Select
End Function

Function convertSetCNoText(ch As String) As String
Select Case ch
Case "1": convertSetCNoText = "a"
Case "2": convertSetCNoText = "s"
Case "3": convertSetCNoText = "d"
Case "4": convertSetCNoText = "f"
Case "5": convertSetCNoText = "g"
Case "6": convertSetCNoText = "h"
Case "7": convertSetCNoText = "j"
Case "8": convertSetCNoText = "k"
Case "9": convertSetCNoText = "l"
Case "0": convertSetCNoText = ";"
End Select
End Function

Function convertSetBText(ch As String) As String
Select Case ch
Case "1": convertSetBText = "Q"
Case "2": convertSetBText = "W"
Case "3": convertSetBText = "E"
Case "4": convertSetBText = "R"
Case "5": convertSetBText = "T"
Case "6": convertSetBText = "Y"
Case "7": convertSetBText = "U"
Case "8": convertSetBText = "I"
Case "9": convertSetBText = "O"
Case "0": convertSetBText = "P"
End Select
End Function
Function convertSetBNoText(ch As String) As String
Select Case ch
Case "1": convertSetBNoText = "q"
Case "2": convertSetBNoText = "w"
Case "3": convertSetBNoText = "e"
Case "4": convertSetBNoText = "r"
Case "5": convertSetBNoText = "t"
Case "6": convertSetBNoText = "y"
Case "7": convertSetBNoText = "u"
Case "8": convertSetBNoText = "i"
Case "9": convertSetBNoText = "o"
Case "0": convertSetBNoText = "p"
End Select
End Function

Function UPCchecksum(digits As String) As String
Dim i As Integer
Dim checkSum As Integer
Dim strLen As Integer
strLen = Len(digits)
For i = 1 To strLen
    If i Mod 2 = 1 Then
        checkSum = checkSum + Val(Mid(digits, strLen - i + 1, 1)) * 3
    Else
        checkSum = checkSum + Val(Mid(digits, strLen - i + 1, 1))
    End If
Next i
UPCchecksum = checkSum Mod 10
If UPCchecksum <> 0 Then UPCchecksum = 10 - UPCchecksum
End Function

Public Function Upce2upca(ByVal digits As String) As String
    If Mid(digits, 1, 1) <> "0" _
        Or Len(digits) <> 7 _
        Or Not IsNumeric(Mid(digits, 2, 6)) Then
        Upce2upca = "00000000000"
        Exit Function
    End If
    Select Case Mid(digits, 7, 1)
        Case "0"
            Upce2upca = Mid(digits, 1, 3) + Mid(digits, 7, 1) + "0000" + Mid(digits, 4, 3)
        Case "1"
            Upce2upca = Mid(digits, 1, 3) + Mid(digits, 7, 1) + "0000" + Mid(digits, 4, 3)
        Case "2"
            Upce2upca = Mid(digits, 1, 3) + Mid(digits, 7, 1) + "0000" + Mid(digits, 4, 3)
        Case "3"
            If InStr(1, "012", Mid(digits, 4, 1), 0) Then
                MsgBox ("Last digit is 3, then the forth digit can not be 0,1,2!")
            Else
                Upce2upca = Mid(digits, 1, 4) + "00000" + Mid(digits, 5, 2)
            End If
        Case "4"
            Upce2upca = Mid(digits, 1, 5) + "00000" + Mid(digits, 6, 1)
        Case "5"
            Upce2upca = Mid(digits, 1, 6) + "0000" + Mid(digits, 7, 1)
        Case "6"
            Upce2upca = Mid(digits, 1, 6) + "0000" + Mid(digits, 7, 1)
        Case "7"
            Upce2upca = Mid(digits, 1, 6) + "0000" + Mid(digits, 7, 1)
        Case "8"
            Upce2upca = Mid(digits, 1, 6) + "0000" + Mid(digits, 7, 1)
        Case "9"
            Upce2upca = Mid(digits, 1, 6) + "0000" + Mid(digits, 7, 1)
        Case Else
            MsgBox ("The last digits of UPC-E code is not a numeric!")
            Exit Function
    End Select
End Function

Public Function Code11(strToEncode As String) As String
Dim CheckSumC As Integer
Dim checksumK As Integer
Dim charSet As String

charSet = "0123456789-"
Code11 = maskfilter(strToEncode, charSet)
CheckSumC = code11Checksum(Code11, 10)
CheckSumC = CheckSumC Mod 11
Code11 = Code11 + Mid(charSet, CheckSumC + 1, 1)

If Len(Code11) > 11 Then
        checksumK = code11Checksum(Code11, 9)
    checksumK = checksumK Mod 11
    Code11 = "*" + Code11 + Mid(charSet, checksumK + 1, 1) + "*"
Else
    Code11 = "*" + Code11 + "*"
End If
End Function

Function maskfilter(strToEncode As String, charSet As String) As String
Dim i As Integer
Dim charPos As Integer
Dim tempChar As String

For i = 1 To Len(strToEncode)
    tempChar = Mid(strToEncode, i, 1)
    charPos = InStr(1, charSet, tempChar, 0)
    If charPos > 0 Then
        maskfilter = maskfilter + Mid(strToEncode, i, 1)
    End If
Next i
End Function
Function code11Checksum(strToEncode As String, mode As Integer) As Integer
Dim i As Integer
Dim strLen As Integer
Dim charPos As Integer
Dim charToEncode As String
Dim charSet As String

charSet = "123456789-"
strLen = Len(strToEncode)
For i = 1 To strLen
    charToEncode = Mid(strToEncode, strLen - i + 1, 1)
    charPos = InStr(1, charSet, charToEncode, 0)
    If charPos > 0 Then code11Checksum = (i Mod mode) * charPos + code11Checksum
Next i
End Function

Public Function Code25(strToEncode As String) As String
Dim charSet As String
charSet = "0123456789"
strToEncode = maskfilter(strToEncode, charSet)
Code25 = "(" + strToEncode + ")"
End Function

Public Function code25Check(strToEncode As String) As String
Dim i As Integer
Dim strLen As Integer
Dim checkSum As Integer
Dim checkDigit As String
Dim charSet As String

charSet = "0123456789"
strToEncode = maskfilter(strToEncode, charSet)

strLen = Len(strToEncode)
For i = 1 To strLen
    If i Mod 2 = 1 Then
        checkSum = checkSum + 3 * Val(Mid(strToEncode, strLen - i + 1, 1))
    Else
        checkSum = checkSum + Val(Mid(strToEncode, strLen - i + 1, 1))
    End If
Next i
checkSum = checkSum Mod 10
If checkSum = 0 Then
    checkDigit = "0"
Else
    checkDigit = Chr(10 - checkSum + Asc("0"))
End If
code25Check = "(" + strToEncode + checkDigit + ")"
End Function

Public Function ITF25Check(strToEncode As String) As String
Dim i As Integer
Dim charToEncode As String
Dim checkDigit As String
Dim charVal As Integer
Dim charSet As String

charSet = "0123456789"
strToEncode = maskfilter(strToEncode, charSet)

If Len(strToEncode) Mod 2 = 0 Then strToEncode = "0" + strToEncode
checkDigit = MOD10(strToEncode)
strToEncode = strToEncode + checkDigit

For i = 1 To Len(strToEncode) Step 2
    charToEncode = Mid(strToEncode, i, 2)
    charVal = Val(charToEncode)
    If charVal >= 0 And charVal <= 93 Then
        ITF25Check = ITF25Check + Chr(Asc("!") + charVal)
    Else
        ITF25Check = ITF25Check + Chr(charVal - 94 + 224)
    End If
Next i
ITF25Check = Chr(230) + ITF25Check + Chr(231)
End Function

Public Function MOD10(strInput As String) As String
Dim i As Integer
Dim checkSum As Integer
Dim strLen As Integer
Dim charSet As String
Dim str As String

charSet = "0123456789"
str = maskfilter(strInput, charSet)

strLen = Len(str)
For i = 1 To strLen
    If i Mod 2 = 1 Then
        checkSum = checkSum + 3 * Val(Mid(str, strLen - i + 1, 1))
    Else
        checkSum = checkSum + Val(Mid(str, strLen - i + 1, 1))
    End If
Next i
checkSum = checkSum Mod 10
If checkSum = 0 Then
    MOD10 = "0"
Else
    MOD10 = Chr(10 - checkSum + Asc("0"))
End If
End Function

Public Function ITF25(strToEncode As String) As String
Dim i As Integer
Dim charToEncode As String
Dim charVal As Integer
Dim charSet As String

charSet = "0123456789"
strToEncode = maskfilter(strToEncode, charSet)
If Len(strToEncode) Mod 2 = 1 Then strToEncode = "0" + strToEncode

For i = 1 To Len(strToEncode) Step 2
    charToEncode = Mid(strToEncode, i, 2)
    charVal = Val(charToEncode)
    If charVal >= 0 And charVal <= 93 Then
        ITF25 = ITF25 + Chr(Asc("!") + charVal)
    Else
        ITF25 = ITF25 + Chr(charVal - 94 + 224)
    End If
Next i

ITF25 = Chr(230) + ITF25 + Chr(231)
End Function

Public Function MSI(strToEncode As String) As String
Dim i As Integer
Dim charToEncode As String
Dim charPos As Integer
Dim checkSum As Integer
Dim checkDigit As String
Dim charVal As Integer
Dim strLen As Integer
Dim newno As String

strToEncode = maskfilter(strToEncode, "0123456789")

strLen = Len(strToEncode)
For i = 1 To strLen
    charToEncode = Mid(strToEncode, i, 1)
    charVal = Val(charToEncode)
    If i Mod 2 = (strLen Mod 2) Then
        newno = newno + charToEncode
    Else
        checkSum = checkSum + charVal
    End If
Next i
newno = str(2 * Val(newno))
For i = 1 To Len(newno)
    checkSum = checkSum + Val(Mid(newno, i, 1))
Next i
checkSum = checkSum Mod 10
If checkSum <> 0 Then
    checkSum = 10 - checkSum
End If
MSI = "[" + strToEncode + Chr(Asc("0") + checkSum) + "]"
End Function

Function Code128aCharSet() As String
    Dim i As Integer
    For i = 32 To 95
        Code128aCharSet = Code128aCharSet + Chr(i)
    Next i
    For i = 0 To 31
        Code128aCharSet = Code128aCharSet + Chr(i)
    Next i
    For i = 241 To 247
        Code128aCharSet = Code128aCharSet + ChrW(i)
    Next i
End Function

Function Code128bCharSet() As String
    Dim i As Integer
    For i = 32 To 127
        Code128bCharSet = Code128bCharSet + Chr(i)
    Next i
    For i = 241 To 247
        Code128bCharSet = Code128bCharSet + ChrW(i)
    Next i
End Function

Function Code128cCharset() As String
    Dim i As Integer
    For i = 0 To 9
        Code128cCharset = Code128cCharset + Chr(i + Asc(0))
    Next i
    For i = 245 To 247
        Code128cCharset = Code128cCharset + ChrW(i)
    Next i
End Function

Function code128MappingSet() As String
    Dim i As Integer
    code128MappingSet = ChrW(252)
    For i = 33 To 126
        code128MappingSet = code128MappingSet + ChrW(i)
    Next i
    For i = 240 To 251
        code128MappingSet = code128MappingSet + ChrW(i)
    Next i
End Function

Function code128CSMapping(ByVal nCode As Long) As Long
    Dim i As Long
    If (nCode = 0) Then
        code128CSMapping = 252
    ElseIf (nCode >= 1 And nCode <= 38) Then
        code128CSMapping = 384 + nCode - 1
    ElseIf (nCode >= 39 And nCode <= 94) Then
        code128CSMapping = 166 + nCode - 39
    Else
        code128CSMapping = 240 + nCode - 95
    End If
End Function

Function code128CCSMapping(ByVal nCode As Long) As Long
    Dim i As Long
    If (nCode = 0) Then
        code128CCSMapping = 253
    ElseIf (nCode >= 1 And nCode <= 38) Then
        code128CCSMapping = 384 + nCode - 1
    ElseIf (nCode >= 39 And nCode <= 99) Then
        code128CCSMapping = 166 + nCode - 39
    Else
        code128CCSMapping = 245 + nCode - 100
    End If
End Function

Public Function code128Auto(ByVal strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim checkSum As Integer
    Dim checkDigit As String
    Dim AcharSet As String
    Dim BcharSet As String
    Dim CcharSet As String
    Dim mappingSet As String
    Dim curCharSet As String
    Dim strLen As Integer
    Dim charVal As Integer
    Dim weight As Integer

    If strToEncode = "" Then
        code128Auto = ""
        Exit Function
    End If

    AcharSet = Code128aCharSet
    BcharSet = Code128bCharSet
    CcharSet = Code128cCharset
    mappingSet = code128MappingSet
    strToEncode = ascii2Char(strToEncode)
    strLen = Len(strToEncode)
    charVal = AscW(Mid(strToEncode, 1, 1))
    If charVal <= 31 Then curCharSet = AcharSet
    If charVal >= 32 And charVal <= 126 Then curCharSet = BcharSet
    If charVal = 242 Then curCharSet = BcharSet
    If charVal = 247 Then curCharSet = CcharSet
    If ((strLen > 4) And IsNumeric(Mid(strToEncode, 1, 4))) Then curCharSet = CcharSet

    Select Case curCharSet
        Case AcharSet
            code128Auto = code128Auto + ChrW(248)
        Case BcharSet
            code128Auto = code128Auto + ChrW(249)
        Case CcharSet
            code128Auto = code128Auto + ChrW(250)
    End Select

    For i = 1 To strLen
        charToEncode = Mid(strToEncode, i, 1)
        charVal = AscW(charToEncode)

        If (charVal = 242) Then
            If curCharSet = CcharSet Then
                code128Auto = code128Auto + ChrW(249)
                curCharSet = BcharSet
            End If
            code128Auto = code128Auto + ChrW(242)
            i = i + 1
            charToEncode = Mid(strToEncode, i, 1)
            charVal = AscW(charToEncode)
        End If

        If (charVal = 247) Then
            code128Auto = code128Auto + ChrW(247)
        ElseIf ((i < strLen - 2) And (IsNumeric(charToEncode)) And (IsNumeric(Mid(strToEncode, i + 1, 1))) And (IsNumeric(Mid(strToEncode, i, 4)))) Or _
        ((i < strLen) And (IsNumeric(charToEncode)) And (IsNumeric(Mid(strToEncode, i + 1, 1))) And (curCharSet = CcharSet)) Then
            If curCharSet <> CcharSet Then
                code128Auto = code128Auto + ChrW(244)
                curCharSet = CcharSet
            End If
            charToEncode = Mid(strToEncode, i, 2)
            charVal = Val(charToEncode)
            code128Auto = code128Auto + Mid(mappingSet, charVal + 1, 1)
            i = i + 1
        ElseIf (((i <= strLen) And (charVal < 31)) Or ((curCharSet = AcharSet) And (charVal > 32 And charVal < 96))) Then
            If curCharSet <> AcharSet Then
                code128Auto = code128Auto + ChrW(246)
                curCharSet = AcharSet
            End If
            charPos = InStr(1, curCharSet, charToEncode, 0)
            code128Auto = code128Auto + Mid(mappingSet, charPos, 1)
        ElseIf (i <= strLen) And (charVal > 31 And charVal < 127) Then
            If curCharSet <> BcharSet Then
                code128Auto = code128Auto + ChrW(245)
                curCharSet = BcharSet
            End If
            charPos = InStr(1, curCharSet, charToEncode, 0)
            code128Auto = code128Auto + Mid(mappingSet, charPos, 1)
        End If
    Next i

    strLen = Len(code128Auto)
    For i = 1 To strLen
        charVal = (AscW(Mid(code128Auto, i, 1)))
        If charVal = 252 Then
            charVal = 0
        ElseIf charVal <= 126 Then
            charVal = charVal - 32
        ElseIf charVal >= 240 Then
            charVal = charVal - 145
        End If
        If i > 1 Then
            weight = i - 1
        Else
            weight = 1
        End If
        checkSum = checkSum + charVal * weight
    Next i
    checkSum = checkSum Mod 103
    checkDigit = Mid(mappingSet, checkSum + 1, 1)
    code128Auto = code128Auto + checkDigit + ChrW(251)
End Function

Public Function Code128A(ByVal strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim checkSum As Long
    Dim checkDigit As Long
    Dim strTemp As String
    Dim AcharSet As String
    Dim mappingSet As String

    AcharSet = Code128aCharSet
    mappingSet = code128MappingSet
    strToEncode = ascii2Char(strToEncode)

    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        charPos = InStr(1, AcharSet, charToEncode, 0)
        If charPos > 0 Then strTemp = strTemp + charToEncode
    Next i

    checkSum = 103
    For i = 1 To Len(strTemp)
        charToEncode = Mid(strTemp, i, 1)
        charPos = InStr(1, AcharSet, charToEncode, 0)
        If charPos > 0 Then
            Code128A = Code128A + Mid(mappingSet, charPos, 1)
            checkSum = checkSum + i * (charPos - 1)
        End If
    Next i

    checkSum = checkSum Mod 103
    checkDigit = code128CSMapping(checkSum)
    Code128A = ChrW(248) + Code128A + ChrW(checkDigit) + ChrW(251)
End Function

Public Function Code128B(ByVal strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim checkSum As Long
    Dim strTemp As String
    Dim checkDigit As Long
    Dim BcharSet As String
    Dim mappingSet As String

BcharSet = Code128bCharSet
mappingSet = code128MappingSet

    strToEncode = ascii2Char(strToEncode)
    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        charPos = InStr(1, BcharSet, charToEncode, 0)
        If charPos > 0 Then strTemp = strTemp + charToEncode
    Next i

    checkSum = 104
    For i = 1 To Len(strTemp)
        charToEncode = Mid(strTemp, i, 1)
        charPos = InStr(1, BcharSet, charToEncode, 0)
        If charPos > 0 Then
            Code128B = Code128B + Mid(mappingSet, charPos, 1)
            checkSum = checkSum + i * (charPos - 1)
        End If
    Next i
    checkSum = checkSum Mod 103
    checkDigit = code128CSMapping(checkSum)
    Code128B = ChrW(249) + Code128B + ChrW(checkDigit) + ChrW(251)
End Function

Public Function Code128C(ByVal strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim checkSum As Long
    Dim strTemp As String
    Dim checkDigit As Long
    Dim charVal As Integer
    Dim CcharSet As String
    Dim mappingSet As String

CcharSet = Code128cCharset
mappingSet = code128MappingSet

    strToEncode = ascii2Char(strToEncode)
    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        charPos = InStr(1, CcharSet, charToEncode, 0)
        If charPos > 0 Then strTemp = strTemp + charToEncode
    Next i
    If Len(strTemp) Mod 2 = 1 Then strTemp = "0" + strTemp

    checkSum = 105
    For i = 1 To Len(strTemp) Step 2
        charToEncode = Mid(strTemp, i, 2)
        charVal = Val(charToEncode)
        Code128C = Code128C + Mid(mappingSet, charVal + 1, 1)
    Next i

    For i = 1 To Len(Code128C)
        charToEncode = Mid(Code128C, i, 1)
        charVal = AscW(charToEncode)
        If charVal = 252 Then
            charVal = 0
        ElseIf charVal >= 33 And charVal < 127 Then
            checkSum = checkSum + i * (charVal - 32)
        Else
            checkSum = checkSum + i * (charVal - 145)
        End If
    Next i
    checkSum = checkSum Mod 103
    checkDigit = code128CCSMapping(checkSum)
    Code128C = ChrW(250) + Code128C + ChrW(checkDigit) + ChrW(251)
End Function

Public Function USPS128(ByVal strToEncode As String) As String
Dim checkDigit As String
Dim charSet As String

    strToEncode = ascii2Char(strToEncode)
    checkDigit = MOD10(strToEncode)
    If (Mid(strToEncode, 1, 1) <> ChrW(247)) Then
        strToEncode = ChrW(247) + strToEncode
    End If
    USPS128 = code128Auto(strToEncode + checkDigit)
End Function

Public Function UCCEAN128(ByVal strToEncode As String) As String
    Dim charSet As String
    Dim i As Integer
    Dim charToEncode As String

strToEncode = ascii2Char(strToEncode)
strToEncode = UCase(strToEncode)

    If (Mid(strToEncode, 1, 1) <> ChrW(247)) Then
        strToEncode = ChrW(247) + strToEncode
    End If

    charSet = Mid(strToEncode, 1, 1)
    For i = 2 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        If (Asc(charToEncode) >= 48 And Asc(charToEncode) <= 57) Or (Asc(charToEncode) >= 65 And Asc(charToEncode) <= 90) Or (charToEncode = ChrW(247)) Then
            charSet = charSet + charToEncode
        End If
    Next i

    UCCEAN128 = code128Auto(charSet)
End Function

Public Function Code93(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim weightC As Integer
    Dim weightK As Integer
    Dim CheckSumC As Integer
    Dim checksumK As Integer
    Dim charSet As String
    Dim mappingSet As String

    charSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%^)&("
    mappingSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-.#$/+%^)&("
    strToEncode = ascii2Char(strToEncode)
    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        If Asc(charToEncode) = 0 Then
            Code93 = Code93 + ")" + "U"
        ElseIf Asc(charToEncode) >= 1 And Asc(charToEncode) <= 26 Then
            Code93 = Code93 + "^" + Chr(Asc(charToEncode) + Asc("A") - 1)
        ElseIf Asc(charToEncode) >= 27 And Asc(charToEncode) <= 31 Then
            Code93 = Code93 + ")" + Chr(Asc(charToEncode) - 27 + Asc("A"))
        ElseIf Asc(charToEncode) = 32 Then 'space
            Code93 = Code93 + "#"
        ElseIf Asc(charToEncode) >= 33 And Asc(charToEncode) <= 44 Then
            Code93 = Code93 + "&" + Chr(Asc(charToEncode) - 33 + Asc("A"))
        ElseIf charToEncode = "-" Then
            Code93 = Code93 + charToEncode
        ElseIf charToEncode = "." Then
            Code93 = Code93 + charToEncode
        ElseIf charToEncode = "/" Then
            Code93 = Code93 + "&" + "O"
        ElseIf Asc(charToEncode) >= 48 And Asc(charToEncode) <= 57 Then
            Code93 = Code93 + charToEncode
        ElseIf charToEncode = ":" Then
            Code93 = Code93 + "&" + "Z"
        ElseIf Asc(charToEncode) >= 59 And Asc(charToEncode) <= 63 Then
            Code93 = Code93 + ")" + Chr(Asc(charToEncode) - 59 + Asc("F"))
        ElseIf Asc(charToEncode) = 64 Then
            Code93 = Code93 + ")" + "V"
        ElseIf Asc(charToEncode) >= 65 And Asc(charToEncode) <= 90 Then
            Code93 = Code93 + charToEncode
        ElseIf Asc(charToEncode) >= 91 And Asc(charToEncode) <= 95 Then
            Code93 = Code93 + ")" + Chr(Asc(charToEncode) - 91 + Asc("K"))
        ElseIf Asc(charToEncode) = 96 Then
            Code93 = Code93 + ")" + "W"
        ElseIf Asc(charToEncode) >= 97 And Asc(charToEncode) <= 122 Then
            Code93 = Code93 + "(" + Chr(Asc(charToEncode) - 97 + Asc("A"))
        ElseIf Asc(charToEncode) >= 123 And Asc(charToEncode) <= 127 Then
            Code93 = Code93 + ")" + Chr(Asc(charToEncode) - 123 + Asc("P"))
        End If
    Next i

    For i = 1 To Len(Code93)
        weightC = ((i - 1) Mod 20) + 1
        charToEncode = Mid(Code93, Len(Code93) - i + 1, 1)
        charPos = InStr(1, mappingSet, charToEncode, 0)
        CheckSumC = CheckSumC + weightC * (charPos - 1)
    Next i
    Code93 = Code93 + Mid(mappingSet, (CheckSumC Mod 47) + 1, 1)

    For i = 1 To Len(Code93)
        weightK = ((i - 1) Mod 15) + 1
        charToEncode = Mid(Code93, Len(Code93) - i + 1, 1)
        charPos = InStr(1, mappingSet, charToEncode, 0)
        checksumK = checksumK + weightK * (charPos - 1)
    Next i
    Code93 = Code93 + Mid(mappingSet, (checksumK Mod 47) + 1, 1)
    Code93 = "*" + Code93 + "*" + "|"
End Function

Public Function Codabar(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim charSet As String

    charSet = "0123456789-$:/.+"
    strToEncode = maskfilter(strToEncode, charSet)
    Codabar = "A" + strToEncode + "B"
End Function

Public Function Code39FullAscii(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charSet As String
    Dim mappingSet As String
    Dim strTemp As String

    strToEncode = ascii2Char(strToEncode)
    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        If Asc(charToEncode) = 0 Then
            strTemp = strTemp + "%U"
        ElseIf Asc(charToEncode) >= 1 And Asc(charToEncode) <= 26 Then
            strTemp = strTemp + "$" + Chr(Asc(charToEncode) + Asc("A") - 1)
        ElseIf Asc(charToEncode) >= 27 And Asc(charToEncode) <= 31 Then
            strTemp = strTemp + "%" + Chr(Asc(charToEncode) - 27 + Asc("A"))
        ElseIf Asc(charToEncode) = 32 Then
            strTemp = strTemp + "="
        ElseIf Asc(charToEncode) >= 33 And Asc(charToEncode) <= 44 Then
            strTemp = strTemp + "/" + Chr(Asc(charToEncode) - 33 + Asc("A"))
        ElseIf charToEncode = "-" Then
            strTemp = strTemp + charToEncode
        ElseIf charToEncode = "." Then
            strTemp = strTemp + charToEncode
        ElseIf charToEncode = "/" Then
            strTemp = strTemp + "/O"
        ElseIf Asc(charToEncode) >= 48 And Asc(charToEncode) <= 57 Then
            strTemp = strTemp + charToEncode
        ElseIf charToEncode = ":" Then
            strTemp = strTemp + "/Z"
        ElseIf Asc(charToEncode) >= 59 And Asc(charToEncode) <= 63 Then
            strTemp = strTemp + "%" + Chr(Asc(charToEncode) - 59 + Asc("F"))
        ElseIf Asc(charToEncode) = 64 Then
            strTemp = strTemp + "%V"
        ElseIf Asc(charToEncode) >= 65 And Asc(charToEncode) <= 90 Then
            strTemp = strTemp + charToEncode
        ElseIf Asc(charToEncode) >= 91 And Asc(charToEncode) <= 95 Then
            strTemp = strTemp + "%" + Chr(Asc(charToEncode) - 91 + Asc("K"))
        ElseIf Asc(charToEncode) = 96 Then
            strTemp = strTemp + "%W"
        ElseIf Asc(charToEncode) >= 97 And Asc(charToEncode) <= 122 Then
            strTemp = strTemp + "+" + Chr(Asc(charToEncode) - 97 + Asc("A"))
        ElseIf Asc(charToEncode) >= 123 And Asc(charToEncode) <= 127 Then
            strTemp = strTemp + "%" + Chr(Asc(charToEncode) - 123 + Asc("P"))
        End If
    Next i
    Code39FullAscii = "*" + strTemp + "*"
End Function

Public Function Code39Extended(strToEncode As String) As String
Dim i As Integer
Dim charToEncode As String
Dim charVal As Integer

strToEncode = ascii2Char(strToEncode)
For i = 1 To Len(strToEncode)
    charToEncode = Mid(strToEncode, i, 1)
    charVal = Asc(charToEncode)
    If charToEncode = " " Then
        Code39Extended = Code39Extended + "#"
    ElseIf charToEncode = "*" Then
        Code39Extended = Code39Extended + Chr(176)
    ElseIf charToEncode = "#" Then
        Code39Extended = Code39Extended + Chr(177)
    ElseIf charVal = 127 Then
        Code39Extended = Code39Extended + Chr(175)
    ElseIf charVal >= 0 And charVal <= 31 Then
        Code39Extended = Code39Extended + Chr(224 + charVal)
    Else
        Code39Extended = Code39Extended + charToEncode
    End If
Next i
Code39Extended = "*" + Code39Extended + "*"
End Function

Public Function Bookland(strToEncode As String) As String
    Dim i As Integer
    Dim charSet As String

    charSet = "0123456789"
    strToEncode = maskfilter(strToEncode, charSet)
    If Len(strToEncode) > 10 Then
        strToEncode = Left(strToEncode, 10)
    ElseIf Len(strToEncode) < 10 Then
        While Len(strToEncode) < 10
            strToEncode = strToEncode + "0"
        Wend
    End If
    Bookland = "978" + Left(strToEncode, 9)
    Bookland = EAN13(Bookland)
End Function

Public Function codeISBN(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPos As Integer
    Dim weight As Integer
    Dim checkSum As Integer
    Dim checkDigit As String
    Dim charSet As String

    charSet = "0123456789"
    strToEncode = maskfilter(strToEncode, charSet)
    If Len(strToEncode) > 9 Then
        strToEncode = Left(strToEncode, 9)
    ElseIf Len(strToEncode) < 9 Then
        While Len(strToEncode) < 9
            strToEncode = strToEncode + "0"
        Wend
    End If
    codeISBN = strToEncode
    For i = 1 To Len(codeISBN)
        weight = 11 - i
        charToEncode = Mid(codeISBN, i, 1)
        checkSum = checkSum + weight * Val(charToEncode)
    Next i
    checkSum = 11 - (checkSum Mod 11)
    checkDigit = Chr(checkSum + Asc("0"))
    codeISBN = codeISBN + checkDigit
End Function

Function LeftHandEncoding(digit As Integer, parity As Integer) As String
    Select Case digit
    Case 0
        If parity = 1 Then
            LeftHandEncoding = "/"
        ElseIf parity = 0 Then
            LeftHandEncoding = "?"
        End If
    Case 1
        If parity = 1 Then
            LeftHandEncoding = "z"
        ElseIf parity = 0 Then
            LeftHandEncoding = "Z"
        End If
    Case 2
        If parity = 1 Then
            LeftHandEncoding = "x"
        ElseIf parity = 0 Then
            LeftHandEncoding = "X"
        End If
    Case 3
        If parity = 1 Then
            LeftHandEncoding = "c"
        ElseIf parity = 0 Then
            LeftHandEncoding = "C"
        End If
    Case 4
        If parity = 1 Then
            LeftHandEncoding = "v"
        ElseIf parity = 0 Then
            LeftHandEncoding = "V"
        End If
    Case 5
        If parity = 1 Then
            LeftHandEncoding = "b"
        ElseIf parity = 0 Then
            LeftHandEncoding = "B"
        End If
    Case 6
        If parity = 1 Then
            LeftHandEncoding = "n"
        ElseIf parity = 0 Then
            LeftHandEncoding = "N"
        End If
    Case 7
        If parity = 1 Then
            LeftHandEncoding = "m"
        ElseIf parity = 0 Then
            LeftHandEncoding = "M"
        End If
    Case 8
        If parity = 1 Then
            LeftHandEncoding = ","
        ElseIf parity = 0 Then
            LeftHandEncoding = "<"
        End If
    Case 9
        If parity = 1 Then
            LeftHandEncoding = "."
        ElseIf parity = 0 Then
            LeftHandEncoding = ">"
        End If
    End Select
End Function
Public Function UPC25SUPP(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim charPosition As Integer
    Dim strLen As Integer

    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        charPosition = InStr(1, "0123456789", charToEncode, 0)
        If charPosition > 0 Then
            UPC25SUPP = UPC25SUPP + charToEncode
        End If
    Next i

    strLen = Len(UPC25SUPP)
    If strLen = 0 Then
        UPC25SUPP = UPC2SUPP("00")
    ElseIf strLen = 1 Then
        UPC25SUPP = UPC2SUPP(UPC25SUPP + "0")
    ElseIf strLen = 2 Then
        UPC25SUPP = UPC2SUPP(UPC25SUPP)
    ElseIf strLen = 3 Then
        UPC25SUPP = UPC5SUPP(UPC25SUPP + "00")
    ElseIf strLen = 4 Then
        UPC25SUPP = UPC5SUPP(UPC25SUPP + "0")
    ElseIf strLen = 5 Then
        UPC25SUPP = UPC5SUPP(UPC25SUPP)
    Else
        UPC25SUPP = UPC5SUPP(Left(UPC25SUPP, 5))
    End If
End Function

Public Function UPC2SUPP(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim nTemp As Integer
    Dim parity1 As Integer
    Dim parity2 As Integer

    nTemp = Val(strToEncode) Mod 4
    If nTemp = 0 Then
        parity1 = 1
        parity2 = 1
    ElseIf nTemp = 1 Then
        parity1 = 1
        parity2 = 0
    ElseIf nTemp = 2 Then
        parity1 = 0
        parity2 = 1
    ElseIf nTemp = 3 Then
        parity1 = 0
        parity2 = 0
    End If

    UPC2SUPP = "{"
    charToEncode = Mid(strToEncode, 1, 1)
    UPC2SUPP = UPC2SUPP + LeftHandEncoding(Val(charToEncode), parity1)
    UPC2SUPP = UPC2SUPP + "/"
    charToEncode = Mid(strToEncode, 2, 1)
    UPC2SUPP = UPC2SUPP + LeftHandEncoding(Val(charToEncode), parity2)
End Function
Function Parity5(digit As Integer) As String
    Select Case digit
    Case 0
        Parity5 = "00111"
    Case 1
        Parity5 = "01011"
    Case 2
        Parity5 = "01101"
    Case 3
        Parity5 = "01110"
    Case 4
        Parity5 = "10011"
    Case 5
        Parity5 = "11001"
    Case 6
        Parity5 = "11100"
    Case 7
        Parity5 = "10101"
    Case 8
        Parity5 = "10110"
    Case 9
        Parity5 = "11010"
    End Select
End Function

Public Function UPC5SUPP(strToEncode As String) As String
    Dim i As Integer
    Dim strParity As String
    Dim weightSum As Integer

    weightSum = 3 * Val(Mid(strToEncode, 1, 1)) + 9 * Val(Mid(strToEncode, 2, 1)) + 3 * Val(Mid(strToEncode, 3, 1)) + 9 * Val(Mid(strToEncode, 4, 1)) + 3 * Val(Mid(strToEncode, 5, 1))
    strParity = Parity5(weightSum Mod 10)

    UPC5SUPP = "{"
    For i = 1 To 5
        UPC5SUPP = UPC5SUPP + LeftHandEncoding(Val(Mid(strToEncode, i, 1)), Val(Mid(strParity, i, 1)))
        If (i < 5) Then
            UPC5SUPP = UPC5SUPP + "/"
        End If
    Next i
End Function

Public Function telepen(ByVal strToEncode As String) As String
    Dim charToEncode As String
    Dim charPos As Integer
    Dim checkSum As Integer
    Dim checkDigit As String
    Dim i As Integer

strToEncode = ascii2Char(strToEncode)

    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        checkSum = checkSum + Asc(charToEncode)
    Next i
    checkDigit = Chr(127 - (checkSum Mod 127))
    strToEncode = strToEncode + checkDigit

    For i = 1 To Len(strToEncode)
        charToEncode = Mid(strToEncode, i, 1)
        If (charToEncode = " ") Then
            telepen = telepen + "#"
        ElseIf (charToEncode = "#") Then
            telepen = telepen + Chr(176)
        ElseIf (charToEncode = "[") Then
            telepen = telepen + Chr(177)
        ElseIf (charToEncode = "]") Then
            telepen = telepen + Chr(178)
        ElseIf (Asc(charToEncode) >= 0 And Asc(charToEncode) <= 31) Then
            telepen = telepen + Chr(Asc(charToEncode) + 224)
        ElseIf (Asc(charToEncode) = 127) Then
            telepen = telepen + Chr(179)
        Else
            telepen = telepen + charToEncode
        End If
    Next i
    telepen = "[" + telepen + "]"
End Function

Public Function telepenNum(strToEncode As String) As String
    Dim i As Integer
    Dim charToEncode As String
    Dim checkSum As Integer
    Dim checkDigit As String
    Dim charVal As Integer
    Dim mappingSet As String
    Dim charSet As String

    charSet = "0123456789"
    strToEncode = maskfilter(strToEncode, charSet)
    If Len(strToEncode) Mod 2 = 1 Then strToEncode = "0" + strToEncode

    For i = 1 To Len(strToEncode) Step 2
        charToEncode = Mid(strToEncode, i, 2)
        charVal = Val(charToEncode) + 27
        mappingSet = mappingSet + Chr(charVal)
    Next i

    For i = 1 To Len(mappingSet)
        charToEncode = Mid(mappingSet, i, 1)
        charVal = Asc(charToEncode)
        checkSum = checkSum + charVal
    Next i
    checkDigit = Chr(127 - (checkSum Mod 127))
    mappingSet = mappingSet + checkDigit

    For i = 1 To Len(mappingSet)
        charToEncode = Mid(mappingSet, i, 1)
        If (charToEncode = " ") Then
            telepenNum = telepenNum + "#"
        ElseIf (charToEncode = "#") Then
            telepenNum = telepenNum + Chr(176)
        ElseIf (charToEncode = "[") Then
            telepenNum = telepenNum + Chr(177)
        ElseIf (charToEncode = "]") Then
            telepenNum = telepenNum + Chr(178)
        ElseIf (Asc(charToEncode) >= 0 And Asc(charToEncode) <= 31) Then
            telepenNum = telepenNum + Chr(Asc(charToEncode) + 224)
        ElseIf (Asc(charToEncode) = 127) Then
            telepenNum = telepenNum + Chr(179)
        Else
            telepenNum = telepenNum + charToEncode
        End If
    Next i
    telepenNum = "[" + telepenNum + "]"
End Function

Function Postnet(strToEncode As String) As String
Dim i As Integer
Dim charToEncode As String
Dim checkSum As Integer
Dim checkDigit As String
Dim charSet As String

charSet = "0123456789"
strToEncode = maskfilter(strToEncode, charSet)
If Len(strToEncode) >= 0 And Len(strToEncode) < 5 Then
    While Len(strToEncode) < 5
        strToEncode = strToEncode + "0"
    Wend
ElseIf Len(strToEncode) > 5 And Len(strToEncode) < 9 Then
    While Len(strToEncode) < 9
        strToEncode = strToEncode + "0"
    Wend
ElseIf Len(strToEncode) > 9 And Len(strToEncode) < 11 Then
    While Len(strToEncode) < 11
        strToEncode = strToEncode + "0"
    Wend
ElseIf Len(strToEncode) > 11 Then
    strToEncode = Left(strToEncode, 11)
End If

For i = 1 To Len(strToEncode)
    charToEncode = Mid(strToEncode, i, 1)
    If IsNumeric(charToEncode) Then
        Postnet = Postnet + charToEncode
        checkSum = checkSum + Val(charToEncode)
    End If
Next i
checkSum = checkSum Mod 10
If checkSum <> 0 Then checkSum = 10 - checkSum
checkDigit = Chr(checkSum + Asc("0"))
Postnet = "[" + Postnet + checkDigit + "]"
End Function

Public Function pdf417(ByVal strToEncode As String) As String
    Dim retval
    On Error GoTo clearmem
    Dim strTemp
    strTemp = ascii2Char(strToEncode)
    cruflBCSObj = CreateObject("cruflBCS.PDF417.1")
    cruflBCSObj.MaxRows = 8
    cruflBCSObj.SetCRLF (1)
    retval = cruflBCSObj.EncodeCR(strTemp, "0")
    pdf417 = retval
clearmem:
    cruflBCSObj = Nothing
End Function

Public Function datamatrix(ByVal strToEncode As String) As String
    Dim retval
    On Error GoTo clearmem
    Dim strTemp
    strTemp = ascii2Char(strToEncode)
    cruflBCSObj = CreateObject("cruflBCS.DataMatrix.1")
    cruflBCSObj.SetCRLF (1)
    retval = cruflBCSObj.EncodeCR(strTemp, "0")
    datamatrix = retval
clearmem:
    cruflBCSObj = Nothing
End Function

Public Function semidatamatrix(ByVal strToEncode As String)
    Dim retval
    On Error GoTo clearmem
    Dim strTemp
    strTemp = ascii2Char(strToEncode)
    cruflBCSObj = CreateObject("BCSSEMIDataMatrix.BCSSEMIDM.1")
    retval = cruflBCSObj.Encode(strTemp)
    semidatamatrix = retval
clearmem:
    cruflBCSObj = Nothing
End Function

Public Function qrcode(ByVal strToEncode As String) As String
    Dim retval
    On Error GoTo clearmem
    Dim strTemp
    strTemp = ascii2Char(strToEncode)
    cruflBCSObj = CreateObject("cruflBCS.QRCode.1")
    cruflBCSObj.SetCRLF (1)
    cruflBCSObj.ECLevel = 1
    retval = cruflBCSObj.EncodeCR(strTemp, "0")
    qrcode = retval
clearmem:
    cruflBCSObj = Nothing
End Function

Public Function code16k(ByVal strToEncode As String) As String
    Dim retval
    On Error GoTo clearmem
    Dim strTemp
    strTemp = ascii2Char(strToEncode)
    cruflBCSObj = CreateObject("cruflBcS.Code16K.1")
    cruflBCSObj.SetCRLF (1)
    retval = cruflBCSObj.Encode(strTemp)
    code16k = retval
clearmem:
    cruflBCSObj = Nothing
End Function

Public Function USSCode128(strToEncode As String) As String
Dim checkDigit As String

strToEncode = ascii2Char(strToEncode)
checkDigit = MOD10(strToEncode)
strToEncode = strToEncode + checkDigit
USSCode128 = Code128B(strToEncode)
End Function

dnvodcwan

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
BarCode 算法 VB类库 2

Option ExplicitPublic Function ascii2Char(strInput As String) As StringDim i As IntegerDim strTemp As StringDim nPos As IntegerDim nValue As Integeri = 1nPos = InStr(i, strInput, "&#", vbTextCompar
复制链接

扫一扫

专栏目录