'/*********************************************************************/ '/* */ '/* Morovia VBScript Functions, part of Morovia Font Tools V3.0 */ '/* (c)2000-2004 Morovia Corporation. All rights reserved. */ '/* Visit http://www.morovia.com/font/ for more information. */ '/* */ '/* You may incorporate this source code in your application as long */ '/* as you own a perpetual license to the font product. */ '/* Distributing the source code, as well as its derivatives, requires */ '/* a developer license. */ '/* Please refer to the license agreement for details. */ '/*********************************************************************/ '/*-------------------------------------------------------------------*/ '/*SpecialChar function allows you to input a character with its 3-digit */ '/*ASCII code instead of the character itself. For example, the Carriage */ '/*Return character (CR) can be inputed as \013, where 13 is the decimal */ '/*value of the character CR. Double backslashes (\\) is treated as one. */ '/*back slash. */ '/*---------------------------------------------------------------------*/ Function SpecialChar(inpara) Dim i, strTemp, nLen nLen = Len(inpara) For i = 1 To nLen strTemp = Mid(inpara, i, 1) If strTemp = "\" Then If i + 1 <= nLen And Mid(inpara, i + 1, 1) = "\" Then SpecialChar = SpecialChar + "\" i = i + 1 ElseIf i + 3 <= nLen And IsNumeric(Mid(inpara, i + 1, 3)) Then SpecialChar = SpecialChar + Chr(CInt(Mid(inpara, i + 1, 3))) i = i + 3 Else SpecialChar = SpecialChar + strTemp End If Else SpecialChar = SpecialChar + strTemp End If Next End Function '/*---------------------------------------------------------------------*/ '/* Function: Code39 - applies to Morovia Code39 Fontware */ '/* Code39(text) Converts the input text into a Code 39 barcode string. The */ '/* function throws off characters not in the Code 39 character set, */ '/* and adds start/stop characters. */ '/*----------------------------------------------------------------------*/ Function Code39(inpara) Dim i, charPos, charToEncode Code39 = "*" inpara = SpecialChar(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, "0123456789.+-/ $%ABCDEFGHIJKLMNOPQRSTUVWXYZ", charToEncode, 0) If charToEncode = " " Then Code39 = Code39 + "=" ElseIf charPos > 0 Then Code39 = Code39 + charToEncode End If Next Code39 = Code39 + "*" End Function 'Code39Mod43 '/*-----------------------------------------------------------------------------*/ '/*Converts the input text into a Code39 extended symbol. This function */ '/*should be used to format Morovia code39 font, not Code39 full ASCII font.*/ '/*The text can be any combinations of ASCII characters. Note that the symbol */ '/*generated is an extended Code39, and the scanner must be put in Code39 */ '/*extended mode to read the symbol properly.*/ '/*----------------------------------------------------------------------------*/ Function Code39Mod43(inpara) Dim charSet, mappingSet, charToEncode Dim i, checkSum, charPos charSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%" mappingSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-.=$/+%" For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, charSet, charToEncode, vbBinaryCompare) checkSum = checkSum + (charPos - 1) Code39Mod43 = Code39Mod43 + Mid(mappingSet, charPos, 1) Next checkSum = checkSum Mod 43 Code39Mod43 = "*" + Code39Mod43 + Mid(mappingSet, checkSum + 1, 1) + "*" End Function 'Code39Extended '/*-------------------------------------------------------------------------------*/ '/*Converts the input text into a Code39 extended symbol. It accepts any ASCII */ '/*characters as input. The only difference from function Code39Ascii is the former */ '/*is designed to work with Morovia Code39(Full ASCII) font and the latter is designed*/ '/*to work with Morovia Code39 font.*/ '/*-----------------------------------------------------------------------------------*/ Function Code39Extended(inpara ) Dim i, charToEncode, charCInt inpara = SpecialChar(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charCInt = Asc(charToEncode) If charToEncode = " " Then Code39Extended = Code39Extended + "=" ElseIf charToEncode = "*" Then Code39Extended = Code39Extended + Chr(244) ElseIf charToEncode = "=" Then Code39Extended = Code39Extended + Chr(240) ElseIf charToEncode = "[" Then Code39Extended = Code39Extended + Chr(241) ElseIf charToEncode = "]" Then Code39Extended = Code39Extended + Chr(242) ElseIf charCInt = 127 Then Code39Extended = Code39Extended + Chr(224) ElseIf charCInt >= 0 And charCInt <= 31 Then Code39Extended = Code39Extended + Chr(192 + charCInt) Else Code39Extended = Code39Extended + charToEncode End If Next Code39Extended = "*" + Code39Extended + "*" End Function 'Code39Ascii '/*Converts the input text into a Code39 extended symbol. This function should be */ '/*used to format Morovia code39 font, not Code39 full ASCII font. The text can be*/ '/*any combinations of ASCII characters. Note that the symbol generated is an extended*/ '/*Code39, and the scanner must be put in Code39 extended mode to read the symbol properly.*/ '/*-----------------------------------------------------------------------------------------*/ Function Code39Ascii(inpara) Dim i, charToEncode, charSet, mappingSet, strTemp inpara = SpecialChar(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) If Asc(charToEncode) = 0 Then 'control characters 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 'control characters strTemp = strTemp + "=" ElseIf Asc(charToEncode) >= 33 And Asc(charToEncode) <= 44 Then strTemp = strTemp + "/" + Chr(Asc(charToEncode) - 33 + Asc("A")) ElseIf charToEncode = "-" Then '45 strTemp = strTemp + charToEncode ElseIf charToEncode = "." Then '46 strTemp = strTemp + charToEncode ElseIf charToEncode = "/" Then '47 strTemp = strTemp + "/O" ElseIf Asc(charToEncode) >= 48 And Asc(charToEncode) <= 57 Then strTemp = strTemp + charToEncode ElseIf charToEncode = ":" Then '58 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 Code39Ascii = "[" + strTemp + "]" End Function 'Code93 '/*Converts the input text into a Code93 symbol. It accepts any ASCII character input,*/ '/*taking care of the check character calculation and adding start/stop characters into*/ '/*the string.*/ '/*------------------------------------------------------------------------------------*/ Function Code93(inpara) Dim i, charToEncode, charPos Dim weightC, weightK, checkSumC Dim checkSumK, charSet, mappingSet, strTemp charSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%@#^&" mappingSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-.=$/+%@#^&" inpara = SpecialChar(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) If Asc(charToEncode) = 0 Then 'control characters 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 'control characters strTemp = strTemp + "=" ElseIf Asc(charToEncode) >= 33 And Asc(charToEncode) <= 44 Then strTemp = strTemp + "^" + Chr(Asc(charToEncode) - 33 + Asc("A")) ElseIf charToEncode = "-" Then '45 strTemp = strTemp + charToEncode ElseIf charToEncode = "." Then '46 strTemp = strTemp + charToEncode ElseIf charToEncode = "/" Then '47 strTemp = strTemp + "^" + "O" ElseIf Asc(charToEncode) >= 48 And Asc(charToEncode) <= 57 Then strTemp = strTemp + charToEncode ElseIf charToEncode = ":" Then '58 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 Code93 = strTemp For i = 1 To Len(Code93) weightC = i Mod 20 ' Added by ben if weightC=0 then weightC=20 end if charToEncode = Mid(Code93, Len(Code93) - i + 1, 1) charPos = InStr(1, mappingSet, charToEncode, 0) checkSumC = checkSumC + weightC * (charPos - 1) Next Code93 = Code93 + Mid(mappingSet, (checkSumC Mod 47) + 1, 1) For i = 1 To Len(Code93) weightK = i Mod 15 ' Added by ben if weightK=0 then weightK=15 end if charToEncode = Mid(Code93, Len(Code93) - i + 1, 1) charPos = InStr(1, mappingSet, charToEncode, 0) checkSumK = checkSumK + weightK * (charPos - 1) Next Code93 = Code93 + Mid(mappingSet, (checkSumK Mod 47) + 1, 1) Code93 = "[" + Code93 + "]" + "|" End Function 'utility functions - EAN/UPC series Function textOnly(onedigit) Select Case onedigit Case "1": textOnly = Chr(193) Case "2": textOnly = Chr(194) Case "3": textOnly = Chr(195) Case "4": textOnly = Chr(196) Case "5": textOnly = Chr(197) Case "6": textOnly = Chr(198) Case "7": textOnly = Chr(199) Case "8": textOnly = Chr(200) Case "9": textOnly = Chr(201) Case "0": textOnly = Chr(192) End Select End Function Function maskfilter(inpara, coderange) Dim i, charPos maskfilter = "" For i = 1 To Len(inpara) charPos = InStr(1, coderange, Mid(inpara, i, 1), 0) If charPos > 0 Then maskfilter = maskfilter + Mid(inpara, i, 1) End If Next End Function Function convertSetAText(onedigit) Select Case onedigit 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(onedigit) Select Case onedigit 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(onedigit) Select Case onedigit 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(onedigit) Select Case onedigit 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(onedigit) Select Case onedigit 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(onedigit) Select Case onedigit 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 LeftHandEncoding(digit, parity) 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(inpara) Dim i, charToEncode, charPosition, strLen For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPosition = InStr(1, "0123456789", charToEncode, 0) If charPosition > 0 Then UPC25SUPP = UPC25SUPP + charToEncode End If Next 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(inpara) Dim i, charToEncode, nTemp Dim parity1, parity2 nTemp = CInt(inpara) 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(inpara, 1, 1) UPC2SUPP = UPC2SUPP + LeftHandEncoding(CInt(charToEncode), parity1) UPC2SUPP = UPC2SUPP + "\" charToEncode = Mid(inpara, 2, 1) UPC2SUPP = UPC2SUPP + LeftHandEncoding(CInt(charToEncode), parity2) End Function Function Parity5(digit) 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(inpara) Dim i, strParity Dim weightSum weightSum = 3 * CInt(Mid(inpara, 1, 1)) + 9 * CInt(Mid(inpara, 2, 1)) + 3 * CInt(Mid(inpara, 3, 1)) + 9 * CInt(Mid(inpara, 4, 1)) + 3 * CInt(Mid(inpara, 5, 1)) strParity = Parity5(weightSum Mod 10) UPC5SUPP = "{" For i = 1 To 5 UPC5SUPP = UPC5SUPP + LeftHandEncoding(CInt(Mid(inpara, i, 1)), CInt(Mid(strParity, i, 1))) If (i < 5) Then UPC5SUPP = UPC5SUPP + "\" End If Next End Function Function getUpcGeneralCheck(digits) Dim i,checkSum, strLen strLen = Len(digits) For i = 1 To strLen If i Mod 2 = 1 Then checkSum = checkSum + CInt(Mid(digits, strLen - i + 1, 1)) * 3 Else checkSum = checkSum + CInt(Mid(digits, strLen - i + 1, 1)) End If Next getUpcGeneralCheck = checkSum Mod 10 If getUpcGeneralCheck <> 0 Then getUpcGeneralCheck = 10 - getUpcGeneralCheck End Function 'EAN13 '/*----------------------------------------------------------------------------------------*/ '/*Converts the input text into an EAN barcode. Accepts input of 12 digits of numeric data.*/ '/*----------------------------------------------------------------------------------------*/ Function EAN13(inpara) Dim i, checkDigit, charToEncode Dim symbmod, symset, symPattern Dim charSet, strSupplement, charPos charSet = "0123456789|" inpara = maskfilter(inpara, charSet) charPos = InStr(1, inpara, "|", 0) If charPos > 0 Then strSupplement = UPC25SUPP(Right(inpara, Len(inpara) - charPos)) inpara = Left(inpara, charPos - 1) End If If Len(inpara) < 12 Then While Len(inpara) < 12 inpara = inpara + "0" Wend ElseIf Len(inpara) > 12 Then inpara = Left(inpara, 12) End If Select Case Mid(inpara, 1, 1) Case 0: symbmod = "AAAAAA" Case 1: symbmod = "AABABB" Case 2: symbmod = "AABBAB" Case 3: symbmod = "AABBBA" Case 4: symbmod = "ABAABB" Case 5: symbmod = "ABBAAB" Case 6: symbmod = "ABBBAA" Case 7: symbmod = "ABABAB" Case 8: symbmod = "ABABBA" Case 9: symbmod = "ABBABA" End Select EAN13 = textOnly(Mid(inpara, 1, 1)) + "[" For i = 2 To 7 symPattern = Mid(symbmod, i - 1, 1) If symPattern = "A" Then EAN13 = EAN13 + convertSetAText(Mid(inpara, i, 1)) ElseIf symPattern = "B" Then EAN13 = EAN13 + convertSetBText(Mid(inpara, i, 1)) End If Next EAN13 = EAN13 + "|" For i = 8 To 12 EAN13 = EAN13 + convertSetCText(Mid(inpara, i, 1)) Next checkDigit = getUpcGeneralCheck(inpara) EAN13 = EAN13 + convertSetCText(checkDigit) + "]" + " " + strSupplement End Function 'EAN8 '/*----------------------------------------------------------------------------------------*/ '/*Converts the input text into an EAN-8 barcode. Accepts input of 7 digits of numeric data.*/ '/*----------------------------------------------------------------------------------------*/ Function EAN8(inpara) Dim i, checkDigit, charToEncode Dim charSet, strSupplement, charPos charSet = "0123456789|" inpara = maskfilter(inpara, charSet) charPos = InStr(1, inpara, "|", 0) If charPos > 0 Then strSupplement = UPC25SUPP(Right(inpara, Len(inpara) - charPos)) inpara = Left(inpara, charPos - 1) End If If Len(inpara) < 7 Then While Len(inpara) < 7 inpara = inpara + "0" Wend ElseIf Len(inpara) > 7 Then inpara = Left(inpara, 7) End If For i = 1 To 4 EAN8 = EAN8 + convertSetAText(Mid(inpara, i, 1)) Next EAN8 = EAN8 + "|" For i = 5 To 7 EAN8 = EAN8 + convertSetCText(Mid(inpara, i, 1)) Next checkDigit = getUpcGeneralCheck(inpara) EAN8 = "[" + EAN8 + convertSetCText(checkDigit) + "]" + " " + strSupplement End Function 'UPC_A. '/*----------------------------------------------------------------------------------------*/ '/*Converts the input text into a UPC-A barcode. Accepts input of 11 digits of numeric data.*/ '/*----------------------------------------------------------------------------------------*/ Function UPC_A(inpara) Dim sysAssign, manfac, product Dim manuStr, prodStr, finalString Dim checkDigit, cnter Dim charSet, strSupplement, charPos charSet = "0123456789|" inpara = maskfilter(inpara, charSet) charPos = InStr(1, inpara, "|", 0) If charPos > 0 Then strSupplement = UPC25SUPP(Right(inpara, Len(inpara) - charPos)) inpara = Left(inpara, charPos - 1) End If If Len(inpara) < 11 Then While Len(inpara) < 11 inpara = inpara + "0" Wend ElseIf Len(inpara) > 11 Then inpara = Left(inpara, 11) End If sysAssign = Mid(inpara, 1, 1) finalString = textOnly(sysAssign) + "[" + convertSetANoText(sysAssign) manuStr = "" For cnter = 1 To 5 manuStr = manuStr + convertSetAText(Mid(inpara, (1 + cnter), 1)) Next finalString = finalString + manuStr prodStr = "" For cnter = 1 To 5 prodStr = prodStr + convertSetCText(Mid(inpara, (6 + cnter), 1)) Next finalString = finalString + "|" + prodStr checkDigit = getUpcGeneralCheck(inpara) finalString = finalString + convertSetCNoText(checkDigit) + "]" + textOnly(checkDigit) UPC_A = finalString + " " + strSupplement End Function 'UPC_E '/*----------------------------------------------------------------------------------------*/ '/*Converts the input text into a UPC-E barcode. Accepts input of 6 digits of numeric data.*/ '/*----------------------------------------------------------------------------------------*/ Function UPC_E(inpara) Dim checkDigit, symbmod, symset, upcaStr, i, charToEncode, charSet, strSupplement, charPos charSet = "0123456789|" inpara = maskfilter(inpara, charSet) charPos = InStr(1, inpara, "|", 0) If charPos > 0 Then strSupplement = UPC25SUPP(Right(inpara, Len(inpara) - charPos)) inpara = Left(inpara, charPos - 1) End If If Len(inpara) < 6 Then While Len(inpara) < 6 inpara = inpara + "0" Wend ElseIf Len(inpara) > 6 Then inpara = Left(inpara, 6) End If inpara = "0" + inpara upcaStr = Upce2upca(inpara) checkDigit = getUpcGeneralCheck(upcaStr) Select Case checkDigit Case 0: symbmod = "BBBAAA" Case 1: symbmod = "BBABAA" Case 2: symbmod = "BBAABA" Case 3: symbmod = "BBAAAB" Case 4: symbmod = "BABBAA" Case 5: symbmod = "BAABBA" Case 6: symbmod = "BAAABB" Case 7: symbmod = "BABABA" Case 8: symbmod = "BABAAB" Case 9: symbmod = "BAABAB" End Select UPC_E = "[" For i = 2 To 7 symset = Mid(symbmod, i - 1, 1) charToEncode = Mid(inpara, i, 1) If symset = "A" Then UPC_E = UPC_E + convertSetAText(charToEncode) ElseIf symset = "B" Then UPC_E = UPC_E + convertSetBText(charToEncode) End If Next UPC_E = textOnly("0") + UPC_E + "'" + textOnly(checkDigit) + " " + strSupplement End Function Public Function upca2upce(digits) If Mid(digits, 1, 1) <> "0" _ Or Len(digits) <> 11 _ Or Not IsNumeric(Mid(digits, 2, 10)) Then MsgBox "UPC-A must be 11 digits long and leaded by 0." Exit Function End If ' 0/1/2 ' 0x00000xxx ' 0x10000xxx ' 0x20000xxx If Mid(digits, 5, 4) = "0000" And InStr(1, "012", Mid(digits, 4, 1), 0) > 0 Then upca2upce = Mid(digits, 1, 3) + Mid(digits, 9, 3) + Mid(digits, 4, 1) ' 3 -- 0xxx00000xx ElseIf Mid(digits, 5, 5) = "00000" Then upca2upce = Mid(digits, 1, 4) + Mid(digits, 10, 2) + "3" ' 4 -- 0xxxx00000x ElseIf Mid(digits, 6, 5) = "00000" Then upca2upce = Mid(digits, 1, 5) + Mid(digits, 11, 1) + "4" ' 5/6/7/8/9 0xxxxx0000[5-9] ElseIf Mid(digits, 7, 4) = "0000" _ And InStr(1, "56789", Mid(digits, 11, 1), 1) Then upca2upce = Mid(digits, 1, 6) + Mid(digits, 11, 1) Else MsgBox "This UPC-A can not be converted to UPC-E code!" End If End Function Function Upce2upca(digits) If Mid(digits, 1, 1) <> "0" _ Or Len(digits) <> 7 _ Or Not IsNumeric(Mid(digits, 2, 6)) Then MsgBox "UPC-E must be leaded by 0 and followed by 6 numeric digits!" 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 'Code11 '/*----------------------------------------------------------------------------------------*/ '/*Converts the input into a valid Code11 symbol. Check digit as well start/stop characters*/ '/*are added into the input.*/ '/*----------------------------------------------------------------------------------------*/ Function Code11(inpara) Dim cCheckSum, kchecksum, ccheckdigit, kcheckdigit, charSet charSet = "0123456789-" Code11 = maskfilter(inpara, charSet) cCheckSum = code11checksum(Code11) cCheckSum = cCheckSum Mod 11 ccheckdigit = Mid(charSet, cCheckSum + 1, 1) Code11 = Code11 + ccheckdigit If Len(Code11) > 11 Then kchecksum = code11checksum(Code11) kchecksum = kchecksum Mod 9 kcheckdigit = Chr(kchecksum + Asc("0")) Code11 = "[" + Code11 + kcheckdigit + "]" Else Code11 = "[" + Code11 + "]" End If End Function 'Code11A Public Function Code11A(inpara) Dim strStageOne, i strStageOne = maskfilter(inpara, "01234567890-") strStageOne = Code11(strStageOne) Code11a = "" For i = 1 To Len(strStageOne) Select Case Mid(strStageOne, i, 1) Case "[": Code11a = Code11a + Mid(strStageOne, i, 1) Case " ": Code11a = Code11a + Mid(strStageOne, i, 1) Case "]": Code11a = Code11a + Mid(strStageOne, i, 1) Case "-": Code11a = Code11a + "_" Case "1": Code11a = Code11a + "!" Case "2": Code11a = Code11a + "@" Case "3": Code11a = Code11a + "#" Case "4": Code11a = Code11a + "$" Case "5": Code11a = Code11a + "%" Case "6": Code11a = Code11a + "^" Case "7": Code11a = Code11a + "&" Case "8": Code11a = Code11a + "*" Case "9": Code11a = Code11a + "(" Case "0": Code11a = Code11a + ")" End Select Next End Function Function code11checksum(inpara) Dim i, strLen, charPos, charToEncode strLen = Len(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, strLen - i + 1, 1) charPos = InStr(1, "0123456789-", charToEncode, 0) If charPos > 0 Then code11checksum = i * (charPos - 1) + code11checksum End If Next End Function 'Code25 '/*----------------------------------------------------------------------------------------*/ '/*Converts the input into a valid Code25 symbol. No check character appended.*/ '/*----------------------------------------------------------------------------------------*/ Function Code25(inpara) Dim i, charToEncode, charPos For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, "0123456789", charToEncode, 0) If charPos > 0 Then Code25 = Code25 + charToEncode Next Code25 = "[" + Code25 + "]" End Function 'Code25Check '/*----------------------------------------------------------------------------------------*/ '/*Converts the input into a valid Code25 symbol. Append a check digit.*/ '/*----------------------------------------------------------------------------------------*/ Function code25Check(inpara) Dim i, charToEncode, charPos, strLen, checkSum, checkDigit ' filter character For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, "0123456789", charToEncode, 0) If charPos > 0 Then code25Check = code25Check + charToEncode End If Next strLen = Len(code25Check) For i = 1 To strLen If i Mod 2 = 1 Then checkSum = checkSum + 3 * CInt(Mid(code25Check, strLen - i + 1, 1)) Else checkSum = checkSum + CInt(Mid(code25Check, strLen - i + 1, 1)) End If Next checkSum = checkSum Mod 10 If checkSum = 0 Then checkDigit = "0" Else checkDigit = Chr(10 - checkSum + Asc("0")) End If code25Check = "[" + code25Check + checkDigit + "]" End Function '/*-----------------------------------------ITF25Check-------------------------------------*/ '/*Converts the input into a valid interleaved 2 of 5 barcode. Append a check digit.*/ '/*----------------------------------------------------------------------------------------*/ Function ITF25Check(inpara) Dim i, charToEncode, charPos, strLen, checkSum, checkDigit, strTemp, charCInt ' filter character For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, "0123456789", charToEncode, 0) If charPos > 0 Then strTemp = strTemp + charToEncode Next strLen = Len(strTemp) If strLen Mod 2 = 0 Then strTemp = strTemp + "0" For i = 1 To strLen If i Mod 2 = 1 Then checkSum = checkSum + 3 * CInt(Mid(strTemp, strLen - i + 1, 1)) Else checkSum = checkSum + CInt(Mid(strTemp, strLen - i + 1, 1)) End If Next checkSum = checkSum Mod 10 If checkSum = 0 Then checkDigit = "0" Else checkDigit = Chr(10 - checkSum + Asc("0")) End If If Len(strTemp) Mod 2 = 0 Then strTemp = strTemp + "0" strTemp = strTemp + checkDigit strLen = Len(strTemp) For i = 1 To strLen Step 2 charToEncode = Mid(strTemp, i, 2) charCInt = CInt(charToEncode) If charCInt >= 0 And charCInt <= 93 Then ITF25Check = ITF25Check + Chr(Asc("!") + charCInt) Else ITF25Check = ITF25Check + Chr(charCInt - 94 + 196) End If Next ITF25Check = Chr(202) + ITF25Check + Chr(203) End Function 'ITF25 '/*----------------------------------------------------------------------------------------*/ '/*Converts the input into a valid interleaved 2 of 5 barcode. No check digit appended in */ '/*this function.*/ '/*----------------------------------------------------------------------------------------*/ Function ITF25(inpara) Dim i, charToEncode, charPos, checkSum, checkDigit, strTemp, charCInt ' filter character For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, "0123456789", charToEncode, 0) If charPos > 0 Then strTemp = strTemp + charToEncode Next If Len(strTemp) Mod 2 = 1 Then strTemp = strTemp + "0" For i = 1 To Len(strTemp) Step 2 charToEncode = Mid(strTemp, i, 2) charCInt = CInt(charToEncode) If charCInt >= 0 And charCInt <= 93 Then ITF25 = ITF25 + Chr(Asc("!") + charCInt) Else ITF25 = ITF25 + Chr(charCInt - 94 + 196) End If Next ITF25 = Chr(202) + ITF25 + Chr(203) End Function '/*---------------------------------------------MSIMod10-----------------------------------*/ '/*Converts the input into a valid MSI/Plessey symbol. Check digit is calculated based on */ '/*Modulo 10 algorithm.*/ '/*----------------------------------------------------------------------------------------*/ Function MSIMod10(inpara) Dim i, charToEncode, charPos, checkSum, checkDigit, charCInt, strLen, choice, newno ' filter character For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, "0123456789", charToEncode, 0) If charPos > 0 Then MSIMod10 = MSIMod10 + charToEncode Next strLen = Len(MSIMod10) choice = strLen Mod 2 For i = 1 To strLen charToEncode = Mid(MSIMod10, i, 1) charCInt = CInt(charToEncode) If i Mod 2 = choice Then newno = newno + charToEncode Else checkSum = checkSum + charCInt End If Next newno = CStr(2 * CInt(newno)) For i = 1 To Len(newno) checkSum = checkSum + CInt(Mid(newno, i, 1)) Next checkSum = checkSum Mod 10 If checkSum <> 0 Then checkSum = 10 - checkSum End If MSIMod10 = "[" + MSIMod10 + Chr(Asc("0") + checkSum) + "]" End Function Function Code128aCharSet() Dim i For i = 32 To 95 Code128aCharSet = Code128aCharSet + Chr(i) Next For i = 0 To 31 Code128aCharSet = Code128aCharSet + Chr(i) Next For i = 193 To 199 Code128aCharSet = Code128aCharSet + Chr(i) Next End Function Function Code128bCharSet() Dim i For i = 32 To 127 Code128bCharSet = Code128bCharSet + Chr(i) Next For i = 193 To 199 Code128bCharSet = Code128bCharSet + Chr(i) Next End Function Function Code128cCharset() Dim i For i = 0 To 9 Code128cCharset = Code128cCharset + Chr(i + Asc(0)) Next For i = 192 To 199 Code128cCharset = Code128cCharset + Chr(i) Next End Function Function code128MappingSet() Dim i code128MappingSet = Chr(204) For i = 33 To 126 code128MappingSet = code128MappingSet + Chr(i) Next For i = 192 To 202 code128MappingSet = code128MappingSet + Chr(i) Next End Function '/*----------------------------------------------code128Auto-------------------------------*/ '/*Encode any ASCII characters. It automatically shift to another character set when the */ '/*encoded character is not found in the current character set.*/ '/*----------------------------------------------------------------------------------------*/ Function code128Auto(inpara) Dim i, charToEncode, charPos, checkSum, checkDigit, AcharSet Dim BcharSet, CcharSet, mappingSet, curCharSet Dim strLen, charCInt, weight AcharSet = Code128aCharSet BcharSet = Code128bCharSet CcharSet = Code128cCharset mappingSet = code128MappingSet inpara = SpecialChar(inpara) If inpara = "" Then code128Auto = "" Exit Function End If strLen = Len(inpara) charCInt = Asc(Mid(inpara, 1, 1)) If charCInt <= 31 Then curCharSet = AcharSet If charCInt >= 32 And charCInt <= 126 Then curCharSet = BcharSet If ((strLen > 4) And IsNumeric(Mid(inpara, 1, 4))) Then curCharSet = CcharSet Select Case curCharSet Case AcharSet code128Auto = code128Auto + Chr(200) Case BcharSet code128Auto = code128Auto + Chr(201) Case CcharSet code128Auto = code128Auto + Chr(202) End Select For i = 1 To strLen charToEncode = Mid(inpara, i, 1) charCInt = Asc(charToEncode) If charCInt = 199 Then code128Auto = code128Auto + Chr(199) ElseIf ((i < strLen - 2) And (IsNumeric(charToEncode)) And (IsNumeric(Mid(inpara, i + 1, 1))) And (IsNumeric(Mid(inpara, i, 4)))) Or _ ((i < strLen) And (IsNumeric(charToEncode)) And (IsNumeric(Mid(inpara, i + 1, 1))) And (curCharSet = CcharSet)) Then If curCharSet <> CcharSet Then code128Auto = code128Auto + Chr(196) curCharSet = CcharSet End If charToEncode = Mid(inpara, i, 2) charCInt = CInt(charToEncode) code128Auto = code128Auto + Mid(mappingSet, charCInt + 1, 1) i = i + 1 ElseIf (((i <= strLen) And (charCInt < 31)) Or ((curCharSet = AcharSet) And (charCInt > 32 And charCInt < 96))) Then If curCharSet <> AcharSet Then code128Auto = code128Auto + Chr(198) curCharSet = AcharSet End If charPos = InStr(1, curCharSet, charToEncode, 0) code128Auto = code128Auto + Mid(mappingSet, charPos, 1) ElseIf (i <= strLen) And (charCInt > 31 And charCInt < 127) Then If curCharSet <> BcharSet Then code128Auto = code128Auto + Chr(197) curCharSet = BcharSet End If charPos = InStr(1, curCharSet, charToEncode, 0) code128Auto = code128Auto + Mid(mappingSet, charPos, 1) End If Next strLen = Len(code128Auto) For i = 1 To strLen charCInt = (Asc(Mid(code128Auto, i, 1))) If charCInt = 204 Then charCInt = 0 ElseIf charCInt <= 126 Then charCInt = charCInt - 32 ElseIf charCInt >= 192 Then charCInt = charCInt - 97 End If If i > 1 Then weight = i - 1 Else weight = 1 End If checkSum = checkSum + charCInt * weight Next checkSum = checkSum Mod 103 checkDigit = Mid(mappingSet, checkSum + 1, 1) code128Auto = code128Auto + checkDigit + Chr(203) + Chr(205) End Function 'Code128A '/*------------------------------------------------Code128A--------------------------------*/ '/*Accepts the input of character set A. Code128 character set consists of capital letters */ '/*and control characters.*/ '/*----------------------------------------------------------------------------------------*/ Function Code128A(inpara) Dim i, charToEncode, charPos, checkSum, checkDigit Dim strTemp, AcharSet, filterSet, mappingSet AcharSet = Code128aCharSet mappingSet = code128MappingSet inpara = SpecialChar(inpara) ' filter characters For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, AcharSet, charToEncode, 0) If charPos > 0 Then strTemp = strTemp + charToEncode Next checkSum = 103 ' start char of 128a 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 checkSum = checkSum Mod 103 checkDigit = Mid(mappingSet, checkSum + 1, 1) Code128A = Chr(200) + Code128A + checkDigit + Chr(203) + Chr(205) End Function 'Code128B '/*----------------------------------------Code128B-----------------------------------------*/ '/*Accepts the input of character set B. Code128 character set consist of all printable */ '/*characters in the ASCII table.*/ '/*----------------------------------------------------------------------------------------*/ Function Code128B(inpara) Dim i, charToEncode, charPos, checkSum, strTemp Dim checkDigit, BcharSet, mappingSet BcharSet = Code128bCharSet mappingSet = code128MappingSet inpara = SpecialChar(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, BcharSet, charToEncode, 0) If charPos > 0 Then strTemp = strTemp + charToEncode Next checkSum = 104 ' start char of code128b 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 checkSum = checkSum Mod 103 checkDigit = Mid(mappingSet, checkSum + 1, 1) Code128B = Chr(201) + Code128B + checkDigit + Chr(203) + Chr(205) End Function 'Code128C '/*----------------------------------------------------------------------------------------*/ '/*Code128 character set C only contains numeric characters. Used when the encoded data */ '/*containing only numbers.*/ '/*----------------------------------------------------------------------------------------*/ Public Function Code128C(inpara ) Dim i, charToEncode, charPos, checkSum Dim strTemp, checkDigit, charCInt, CcharSet Dim mappingSet CcharSet = Code128cCharset mappingSet = code128MappingSet ' filter unaccepted characters inpara = SpecialChar(inpara) For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, CcharSet, charToEncode, 0) If charPos > 0 Then strTemp = strTemp + charToEncode Next If Len(strTemp) Mod 2 = 1 Then strTemp = strTemp + "0" checkSum = 105 For i = 1 To Len(strTemp) Step 2 charToEncode = Mid(strTemp, i, 2) charCInt = CInt(charToEncode) Code128C = Code128C + Mid(mappingSet, charCInt + 1, 1) Next For i = 1 To Len(Code128C) charToEncode = Mid(Code128C, i, 1) charCInt = Asc(charToEncode) If charCInt = 204 Then charCInt = 0 ElseIf charCInt >= 33 And charCInt < 127 Then checkSum = checkSum + i * (charCInt - 32) Else checkSum = checkSum + i * (charCInt - 97) End If Next checkSum = checkSum Mod 103 checkDigit = Mid(mappingSet, checkSum + 1, 1) Code128C = Chr(202) + Code128C + checkDigit + Chr(203) + Chr(205) End Function '/*--------------------------Bookland----------------------*/ '/*Converts an ISBN string into a valid Bookland barcode. */ '/*--------------------------------------------------------*/ Function Bookland(inpara) Dim i, charSet charSet = "0123456789" inpara = maskfilter(inpara, charSet) If Len(inpara) > 10 Then inpara = Left(inpara, 10) ElseIf Len(inpara) < 10 Then While Len(inpara) < 10 inpara = inpara + "0" Wend End If Bookland = "978" + Left(inpara, 9) Bookland = EAN13(Bookland) End Function Function codeISBN(inpara) Dim i, charToEncode, charPos Dim weight, checkSum, checkDigit, charSet charSet = "0123456789" inpara = maskfilter(inpara, charSet) If Len(inpara) > 9 Then inpara = Left(inpara, 9) ElseIf Len(inpara) < 9 Then While Len(inpara) < 9 inpara = inpara + "0" Wend End If codeISBN = inpara For i = 1 To Len(codeISBN) weight = 11 - i charToEncode = Mid(codeISBN, i, 1) checkSum = checkSum + weight * CInt(charToEncode) Next checkSum = 11 - (checkSum Mod 11) checkDigit = Chr(checkSum + Asc("0")) codeISBN = codeISBN + checkDigit End Function Function EAN128(inpara) Dim i, charToEncode, strCodeWord, strTemp Dim strLen, checkSum, checkDigit, weight Dim charCIntue, mappingSet mappingSet = code128MappingSet inpara = SpecialChar(inpara) strLen = Len(inpara) For i = 1 To strLen If Mid(inpara, i, 1) = Chr(199) Then strTemp = strTemp + Chr(199) ElseIf IsNumeric(Mid(inpara, i, 1)) Then If i + 1 <= strLen And IsNumeric(Mid(inpara, i + 1, 1)) Then strTemp = strTemp + Mid(inpara, i, 2) i = i + 1 Else strTemp = strTemp + Mid(inpara, i, 1) + "0" End If End If Next strLen = Len(strTemp) checkSum = 105 + 102 weight = 2 For i = 1 To strLen charToEncode = Mid(strTemp, i, 1) If charToEncode <> Chr(199) Then ' not FNC1 charCIntue = CInt(Mid(strTemp, i, 2)) strCodeWord = strCodeWord + Mid(mappingSet, charCIntue + 1, 1) charCIntue = charCIntue * weight i = i + 1 Else ' Fnc1 strCodeWord = strCodeWord + Chr(199) charCIntue = 102 * weight End If checkSum = checkSum + charCIntue weight = weight + 1 Next checkSum = checkSum Mod 103 checkDigit = Mid(mappingSet, checkSum + 1, 1) EAN128 = Chr(202) + Chr(199) + strCodeWord + checkDigit + Chr(203) + Chr(205) End Function '/*------------------------------------------------------------------ */ '/*** EAN128Ex funciton replaces the EAN128 function */ '/* It takes input of a well formated EAN128 data with parenthesises. */ '/* For example, to encode a coupon code (8101)0 54321 1200(21)12345678 */ '/* Just use it as the input. You must calculate the EAN128 check digit */ '/* by yourself if it required. */ '/*----------------------------------------------------------------------*/ Function EAN128Ex(inpara) Dim str str = Replace(inpara, "(", "\199") str = Replace(str, ")", "" ) str = Replace(str, " ", "" ) EAN128Ex = EAN128(str) End Function Function SCC14(inpara) Dim i, charToEncode, strTemp Dim strLen, checkSum, checkDigit Dim weight, charCIntue strLen = Len(inpara) For i = 1 To strLen charToEncode = Mid(inpara, i, 1) If charToEncode >= "0" And charToEncode <= "9" Then strTemp = strTemp + charToEncode End If Next If Len(strTemp) = 14 Then strTemp = Mid(strTemp, 1, 13) If Len(strTemp) = 15 Or Len(strTemp) = 16 Or Len(strTemp) = 17 Then strTemp = Mid(strTemp, 3, 13) If Len(strTemp) <> 13 Then Exit Function strLen = Len(strTemp) For i = 1 To strLen charCIntue = CInt(Mid(strTemp, strLen - i + 1, 1)) If i Mod 2 = 1 Then weight = 3 Else weight = 1 End If checkSum = checkSum + charCIntue * weight Next checkSum = checkSum Mod 10 If checkSum = 0 Then checkDigit = "0" Else checkDigit = Chr(10 - checkSum + Asc("0")) End If SCC14 = EAN128("01" + strTemp + checkDigit) End Function 'SSCC18 Function SSCC18(inpara) Dim i, charToEncode, strTemp Dim strLen, checkSum, checkDigit Dim weight, charCIntue inpara = SpecialChar(inpara) strLen = Len(inpara) For i = 1 To strLen charToEncode = Mid(inpara, i, 1) If charToEncode >= "0" And charToEncode <= "9" Then strTemp = strTemp + charToEncode End If Next If Len(strTemp) = 18 Then strTemp = Mid(strTemp, 1, 17) If Len(strTemp) = 19 Or Len(strTemp) = 20 Or Len(strTemp) = 21 Then strTemp = Mid(strTemp, 3, 17) If Len(strTemp) <> 17 Then Exit Function strLen = Len(strTemp) For i = 1 To strLen charCIntue = CInt(Mid(strTemp, strLen - i + 1, 1)) If i Mod 2 = 1 Then weight = 3 Else weight = 1 End If checkSum = checkSum + charCIntue * weight Next checkSum = checkSum Mod 10 If checkSum = 0 Then checkDigit = "0" Else checkDigit = Chr(10 - checkSum + Asc("0")) End If SSCC18 = EAN128("00" + strTemp + checkDigit) End Function 'USPS_EAN128 Function USPS_EAN128(inpara) Dim i, charToEncode, strTemp Dim strLen, checkSum, checkDigit Dim weight, charCIntue inpara = SpecialChar(inpara) strLen = Len(inpara) For i = 1 To strLen charToEncode = Mid(inpara, i, 1) If charToEncode >= "0" And charToEncode <= "9" Then strTemp = strTemp + charToEncode End If Next If Len(strTemp) > 19 Then strTemp = Mid(strTemp, 1, 19) If Len(strTemp) <> 19 Then strTemp = "0000000000000000000" strTemp = "91" + strTemp strLen = Len(strTemp) For i = 1 To strLen charCIntue = CInt(Mid(strTemp, strLen - i + 1, 1)) If i Mod 2 = 1 Then weight = 3 Else weight = 1 End If checkSum = checkSum + charCIntue * weight Next checkSum = checkSum Mod 10 If checkSum = 0 Then checkDigit = "0" Else checkDigit = Chr(10 - checkSum + Asc("0")) End If USPS_EAN128 = EAN128(strTemp + checkDigit) End Function 'USPS_USS128 '/*----------------------------------------------------------------------------------------*/ '/*Used for 22 digit USPS special services labels such as delivery confirmation in EAN128. */ '/*This function takes 19 digit input which is made up of the three parts: 2 digit service */ '/*code, 9 digit customer ID and 8 digit sequential package ID. This function calculates the*/ '/*check digit (Mod10), add the application identifier 91 as required by the USPS standard,*/ '/*and format the data with EAN128 standard. */ '/*----------------------------------------------------------------------------------------*/ Public Function USPS_USS128(inpara) Dim i, charToEncode, strTemp Dim strLen, checkSum, checkDigit, weight, charCIntue inpara = SpecialChar(inpara) strLen = Len(inpara) For i = 1 To strLen charToEncode = Mid(inpara, i, 1) If charToEncode >= "0" And charToEncode <= "9" Then strTemp = strTemp + charToEncode End If Next If Len(strTemp) = 20 Then strTemp = Mid(strTemp, 1, 19) If Len(strTemp) <> 19 Then Exit Function strLen = Len(strTemp) For i = 1 To strLen charCIntue = CInt(Mid(strTemp, strLen - i + 1, 1)) If i Mod 2 = 1 Then weight = 3 Else weight = 1 End If checkSum = checkSum + charCIntue * weight Next checkSum = checkSum Mod 10 If checkSum = 0 Then checkDigit = "0" Else checkDigit = Chr(10 - checkSum + Asc("0")) End If USPS_USS128 = Code128C(strTemp + checkDigit) End Function 'RoyalMail '/*----------------------------------------------------------------------------*/ '/*Converts the input into a valid UK royal mail barcode symbol with checksum. */ '/*The function adds the start/stop frame bar, calculating the check digit and */ '/*forms the correct symbol.*/ '/*----------------------------------------------------------------------------*/ Function RoyalMail(inpara) Dim i, charToEncode, charSet, charPos Dim charCInt, checkSum, checkDigit, tu, tl, temp charSet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) charPos = InStr(1, charSet, charToEncode, vbBinaryCompare) If (charPos > 0) Then RoyalMail = RoyalMail + charToEncode charCInt = Asc(charToEncode) If (charCInt < 65) Then charCInt = charCInt - 48 Else charCInt = charCInt - 55 End If temp = Int(charCInt / 6) If (temp >= 5) Then checkSum = 0 Else checkSum = temp + 1 tu = tu + checkSum temp = Int(charCInt - temp * 6) If temp >= 5 Then checkSum = 0 Else checkSum = temp + 1 tl = tl + checkSum End If Next tu = tu Mod 6 If tu = 0 Then tu = 6 tl = tl Mod 6 If tl = 0 Then tl = 6 checkSum = (tu - 1) * 6 + tl - 1 If checkSum < 10 Then checkDigit = Chr(checkSum + 48) Else checkDigit = Chr(checkSum + 55) End If RoyalMail = "[" + RoyalMail + checkDigit + "]" End Function 'POSTNET '/*-----------------------------------------------------------------------*/ '/*Converts the input into a valid POSTNET barcode string with checksum.*/ '/*The function adds the start/stop frame bar, calculating the check digit*/ '/*and forms the correct symbol. This function can also be used to generate*/ '/*PLANET barcode string.*/ '/*-----------------------------------------------------------------------*/ Function Postnet(inpara) Dim i, charToEncode, checkSum, checkDigit For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) If IsNumeric(charToEncode) Then Postnet = Postnet + charToEncode checkSum = checkSum + CInt(charToEncode) End If Next checkSum = checkSum Mod 10 If checkSum <> 0 Then checkSum = 10 - checkSum checkDigit = Chr(checkSum + Asc("0")) Postnet = "[" + Postnet + checkDigit + "]" End Function 'Codabar '/*----------------------------------------------------------------------------------------*/ '/*Converts the input into a valid Codabar symbol. The default start/stop characters are “A?/ '/*and “B?*/ '/*----------------------------------------------------------------------------------------*/ Function Codabar(inpara) Dim i, charToEncode, charPos, charSet charSet = "0123456789-$:/.+" For i = 1 To Len(inpara) charToEncode = Mid(inpara, i, 1) 'definition of a CIntid Codabar character set. charPos = InStr(1, charSet, charToEncode, 0) If charPos > 0 Then Codabar = Codabar + charToEncode Next Codabar = "A" + Codabar + "B" End Function