' ' pb_bar.bas ' ' AUTHOR ' Barcode generation Adapted for pbcc/pbdll ' by Don Dickinson ' ddickinson@usinternet.com ' ' Adapted from David J Walker's Public Domain Code ' as posted at www.powerbasic.com in the support forums code area ' ' David J Walker ' dave@auk2000.co.uk ' ' Author's Original Comments: ' Public Domain. Use as you wish. Acknowlegement to David J Walker ' would be appreciated. Perhaps not very stylish, but it works! ' ' LICENSE ' Public Domain ' Use at your own risk ' ' DEPENDS ON ' no other files ' %True and %False are defined if not already defined. ' ' FUNCTIONS ' pbBarCode(bcType, sNumber, iCheck) as String ' bcType = one of the %BC_TYPE_xxx constants ' sNumber = the string to evaluate ' iCheck = include checksum - EAN8 and UPC have ' an optional check digit. Setting this ' to non-zero includes that digit. ' Returns = If the string can be evaluated, the barcode ' representation in 1/0 format will be returned ' if invalid digits are passed or the string ' is otherwise invalid, "" is returned ' ' NOTES ' The separate bar code routines (1 for each type) may also be ' directly called. The individual functions are not documented, ' but have parameters directly corresponding to pbBarCode. ' #if not %def(%PB_BAR_BAS) %PB_BAR_BAS = 1 #if not %def(%True) %True = -1 #endif #if not %def(%False) %False = 0 #endif '- Type parameters for the pbBarCode function %BC_TYPE_UPC = 0 %BC_TYPE_ITF = 1 %BC_TYPE_39 = 2 %BC_TYPE_EAN8 = 3 %BC_TYPE_EAN13 = 4 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbbarEAN13 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbbarEAN13 Alias "pbbarEAN13" _ ( ByVal sNumber as String ) Export as String Dim n as Long Dim s as String Dim sCheck as String Dim sPatt as String IF LEN(sNumber) <> 13 THEN Function = "" exit function end if s = "101" 'start sCheck = LEFT$(sNumber, 1) sNumber = RIGHT$(sNumber, 12) SELECT CASE sCheck CASE "0" sPatt = "AAAAAA" CASE "1" sPatt = "AABABB" CASE "2" sPatt = "AABBAB" CASE "3" sPatt = "AABBBA" CASE "4" sPatt = "ABAABB" CASE "5" sPatt = "ABBAAB" CASE "6" sPatt = "ABBBAA" CASE "7" sPatt = "ABABAB" CASE "8" sPatt = "ABABBA" CASE "9" sPatt = "ABBABA" END SELECT FOR n = 1 TO 12 IF n < 7 THEN SELECT CASE MID$(sPatt, n, 1) CASE "A" SELECT CASE MID$(sNumber, n, 1) CASE "0" s = s + "0001101" CASE "1" s = s + "0011001" CASE "2" s = s + "0010011" CASE "3" s = s + "0111101" CASE "4" s = s + "0100011" CASE "5" s = s + "0110001" CASE "6" s = s + "0101111" CASE "7" s = s + "0111011" CASE "8" s = s + "0110111" CASE "9" s = s + "0001011" END SELECT CASE "B" SELECT CASE MID$(sNumber, n, 1) CASE "0" s = s + "0100111" CASE "1" s = s + "0110011" CASE "2" s = s + "0011011" CASE "3" s = s + "0100001" CASE "4" s = s + "0011101" CASE "5" s = s + "0111001" CASE "6" s = s + "0000101" CASE "7" s = s + "0010001" CASE "8" s = s + "0001001" CASE "9" s = s + "0010111" END SELECT END SELECT ELSE IF n = 7 THEN s = s + "01010" END IF SELECT CASE MID$(sNumber, n, 1) CASE "0" s = s + "1110010" CASE "1" s = s + "1100110" CASE "2" s = s + "1101100" CASE "3" s = s + "1000010" CASE "4" s = s + "1011100" CASE "5" s = s + "1001110" CASE "6" s = s + "1010000" CASE "7" s = s + "1000100" CASE "8" s = s + "1001000" CASE "9" s = s + "1110100" END SELECT END IF NEXT Function = s + "101" End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbbarEAN8 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbbarEAN8 Alias "pbbarEAN8" _ ( ByVal sNumber as String, ByVal iCheck as Long ) Export as String Dim n as Long Dim b as Long Dim s as String Dim iCheckDigit as Long Dim numberA as String ' ' Left hand Guard 01010 ' 4 odd parity digits ' Centre Guard 01010 ' 4 even Parity digits ' Right hand guard 101 ' '- Checksum digit numberA = sNumber iCheckDigit = 0 IF iCheck THEN FOR n = 1 TO LEN(numberA) IF (n MOD 2) = 1 THEN iCheckDigit = iCheckDigit + int(val(mid$(numberA, n, 1))) ELSE iCheckDigit = iCheckDigit + 3 * int(val(mid$(numberA, n, 1))) END IF NEXT n iCheckDigit = iCheckDigit mod 10 iCheckDigit = (10 - iCheckDigit) mod 10 numberA = numberA + chr$(48 + iCheckDigit) END IF s = "101" IF LEN(numberA) / 2 <> INT(LEN(numberA) / 2) THEN numberA = "0" + numberA ELSE numberA = sNumber END IF FOR n = 1 TO LEN(numberA) b = ASC(MID$(numberA, n, 1)) IF (b < 48) OR (b > 57) THEN Function = "" Exit function END IF b = b - 48 SELECT CASE b CASE 0 IF n <= LEN(numberA) / 2 THEN s = s + "0001101" ELSE s = s + "1110010" END IF CASE 1 IF n <= LEN(numberA) / 2 THEN s = s + "0011001" ELSE s = s + "1100110" END IF CASE 2 IF n <= LEN(numberA) / 2 THEN s = s + "0010011" ELSE s = s + "1101100" END IF CASE 3 IF n <= LEN(numberA) / 2 THEN s = s + "0111101" ELSE s = s + "1000010" END IF CASE 4 IF n <= LEN(numberA) / 2 THEN s = s + "0100011" ELSE s = s + "1011100" END IF CASE 5 IF n <= LEN(numberA) / 2 THEN s = s + "0110001" ELSE s = s + "1001110" END IF CASE 6 IF n <= LEN(numberA) / 2 THEN s = s + "0101111" ELSE s = s + "1010000" END IF CASE 7 IF n <= LEN(numberA) / 2 THEN s = s + "0111011" ELSE s = s + "1000100" END IF CASE 8 IF n <= LEN(numberA) / 2 THEN s = s + "0110111" ELSE s = s + "1001000" END IF CASE 9 IF n <= LEN(numberA) / 2 THEN s = s + "0001011" ELSE s = s + "1110100" END IF END SELECT IF n * 2 = LEN(numberA) THEN s = s + "01010" END IF NEXT n Function = s + "101" End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbbar39 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbbar39 Alias "pbbar39" _ ( ByVal sNumber as String ) Export as String Dim n as Long Dim s as String Dim numberA as String sNumber = UCase$(sNumber) numberA = "*" + sNumber + "*" s = "" for n = 1 TO Len(numberA) Select Case Mid$(numberA, n, 1) CASE "1" s = s + "110100101011" CASE "2" s = s + "101100101011" CASE "3" s = s + "110110010101" CASE "4" s = s + "101001101011" CASE "5" s = s + "110100110101" CASE "6" s = s + "101100110101" CASE "7" s = s + "101001011011" CASE "8" s = s + "110100101101" CASE "9" s = s + "101100101101" CASE "0" s = s + "101001101101" CASE "A" s = s + "110101001011" CASE "B" s = s + "101101001011" CASE "C" s = s + "110110100101" CASE "D" s = s + "101011001011" CASE "E" s = s + "110101100101" CASE "F" s = s + "101101100101" CASE "G" s = s + "101010011011" CASE "H" s = s + "110101001101" CASE "I" s = s + "101101001101" CASE "J" s = s + "101011001101" CASE "K" s = s + "110101010011" CASE "L" s = s + "101101010011" CASE "M" s = s + "110110101001" CASE "N" s = s + "101011010011" CASE "O" s = s + "110101101001" CASE "P" s = s + "101101101001" CASE "Q" s = s + "101010110011" CASE "R" s = s + "110101011001" CASE "S" s = s + "101101011001" CASE "T" s = s + "101011011001" CASE "U" s = s + "110010101011" CASE "V" s = s + "100110101011" CASE "W" s = s + "110011010101" CASE "X" s = s + "100101101011" CASE "Y" s = s + "110010110101" CASE "Z" s = s + "100110110101" CASE "-" s = s + "100101011011" CASE "." s = s + "110010101101" CASE " " s = s + "100110101101" CASE "*" s = s + "100101101101" CASE "$" s = s + "100100100101" CASE "/" s = s + "100100100101" CASE "+" s = s + "100101001001" CASE "%" s = s + "101001001001" CASE ELSE Function = "" Exit Function End Select s = s + "0" NEXT n Function = s End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbbarUPC '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbbarUPC Alias "pbbarUPC" _ ( ByVal sNumber as String, ByVal iCheck as Long ) Export as String Dim n as Long Dim b as Long Dim iCheckDigit as Long Dim s as String Dim numberA as String numberA = sNumber '- Determine the checksum digit iCheckDigit = 0 if iCheck then FOR n = 1 TO len(numberA) IF (n mod 2) = 1 THEN iCheckDigit = iCheckDigit + int(Val(mid$(numberA, n, 1))) ELSE iCheckDigit = iCheckDigit + 3 * int(val(mid$(numberA, n, 1))) END IF NEXT n iCheckDigit = iCheckDigit MOD 10 iCheckDigit = (10 - iCheckDigit) MOD 10 numberA = numberA + CHR$(48 + iCheckDigit) End If '- make it an even number of digits if len(numberA) mod 2 <> 0 then numberA = "0" + numberA end if s = "101" 'IF LEN(numberA) / 2 <> INT(LEN(numberA) / 2) THEN ' numberA = "0" + NumberA 'ELSE ' numberA = sNumber 'END IF FOR n = 1 TO len(numberA) b = ASC(MID$(numberA, n, 1)) '- Barcode error IF (b < 48) OR (b > 57) THEN Function = "" exit function END IF b = b - 48 Select Case b Case 0 if n <= len(numberA) / 2 THEN s = s + "0001101" else s = s + "1110010" End If CASE 1 IF n <= LEN(numberA) / 2 THEN s = s + "0011001" ELSE s = s + "1100110" END IF CASE 2 IF n <= LEN(numberA) / 2 THEN s = s + "0010011" ELSE s = s + "1101100" END IF CASE 3 IF n <= LEN(numberA) / 2 THEN s = s + "0111101" ELSE s = s + "1000010" END IF CASE 4 IF n <= LEN(numberA) / 2 THEN s = s + "0100011" ELSE s = s + "1011100" END IF CASE 5 IF n <= LEN(numberA) / 2 THEN s = s + "0110001" ELSE s = s + "1001110" END IF CASE 6 IF n <= LEN(numberA) / 2 THEN s = s + "0101111" ELSE s = s + "1010000" END IF CASE 7 IF n <= LEN(numberA) / 2 THEN s = s + "0111011" ELSE s = s + "1000100" END IF CASE 8 IF n <= LEN(numberA) / 2 THEN s = s + "0110111" ELSE s = s + "1001000" END IF CASE 9 IF n <= len(numberA) / 2 THEN s = s + "0001011" ELSE s = s + "1110100" END IF END SELECT IF n * 2 = LEN(numberA) THEN s = s + "01010" END IF NEXT n Function = s + "101" End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbbarITF '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbbarITF Alias "pbbarITF" _ ( ByVal sNumber as String ) Export as String Dim n as Long Dim b as Long Dim s as String Dim s1 as String Dim s2 as String Dim numberA as String s1 = "" s2 = "" '- If it's an odd number of digits, add a zero in front if len(numberA) mod 2 <> 0 then numberA = "0" + sNumber else numberA = sNumber end if 'IF LEN(numberA) / 2 <> INT(LEN(numberA) / 2) THEN ' numberA = "0" + numberA 'ELSE ' numberA = sNumber 'END IF FOR n = 1 TO LEN(numberA) STEP 2 b = ASC(MID$(numberA, n, 1)) IF b < 48 OR b > 57 THEN Function = "" exit function END IF b = b - 48 SELECT CASE b CASE 0 s1 = s1 + "NNWWN" CASE 1 s1 = s1 + "WNNNW" CASE 2 s1 = s1 + "NWNNW" CASE 3 s1 = s1 + "WWNNN" CASE 4 s1 = s1 + "NNWNW" CASE 5 s1 = s1 + "WNWNN" CASE 6 s1 = s1 + "NWWNN" CASE 7 s1 = s1 + "NNNWW" CASE 8 s1 = s1 + "WNNWN" CASE 9 s1 = s1 + "NWNWN" END SELECT NEXT n FOR n = 2 TO LEN(numberA) STEP 2 b = ASC(MID$(numberA, n, 1)) IF (b < 48) OR (b > 57) THEN Function = "" Exit Function END IF b = b - 48 SELECT CASE b CASE 0 s2 = s2 + "NNWWN" CASE 1 s2 = s2 + "WNNNW" CASE 2 s2 = s2 + "NWNNW" CASE 3 s2 = s2 + "WWNNN" CASE 4 s2 = s2 + "NNWNW" CASE 5 s2 = s2 + "WNWNN" CASE 6 s2 = s2 + "NWWNN" CASE 7 s2 = s2 + "NNNWW" CASE 8 s2 = s2 + "WNNWN" CASE 9 s2 = s2 + "NWNWN" END SELECT Next n s = "" FOR n = 1 TO LEN(s1) IF MID$(s1, n, 1) = "N" THEN s = s + "1" ELSE s = s + "11" END IF IF MID$(s2, n, 1) = "N" THEN s = s + "0" ELSE s = s + "00" END IF NEXT n Function = "01010" + s + "11010" End Function '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbBarCode '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbBarCode Alias "pbBarCode" _ ( ByVal bcType as Long, ByVal sNumber as String, ByVal iCheck as Long ) _ export as String ' "UPC" - Universal Product Code Check digit ' "ITF" - Interleaved 2 of 5 No Check Digit ' "39" - 3 of 9 No Check Digit ' "EAN8" - European Article Numbering 8 Digits Check Digit ' "EAN13" - European Article Numbering 13 Digits Check Digit ' Dim n as Long Dim b as Long Dim numberA as String Dim s as String Dim s1 as String Dim s2 as String Select Case bcType Case %BC_TYPE_UPC Function = pbbarUPC(sNumber, iCheck) Case %BC_TYPE_ITF Function = pbbarITF(sNumber) Case %BC_TYPE_39 Function = pbbar39(sNumber) Case %BC_TYPE_EAN8 Function = pbbarEAN8(sNumber, iCheck) Case %BC_TYPE_EAN13 Function = pbbarEAN13(sNumber) Case else Function = "" End Select END FUNCTION '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' pbbarCheckEAN13 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Function pbbarCheckEAN13 Alias "pbbarCheckEAN13" _ ( ByVal ean as String ) Export as Long Dim iCount as Long Dim iAcc as Long Dim iAcc1 as Long Dim iAcc2 as Long iAcc2 = 0 For iCount = 12 to 2 Step -2 iAcc1 = iAcc1 + int(Val(Mid$(ean, iCount, 1))) Next iCount For iCount = 11 to 1 Step -2 iAcc2 = iAcc2 + int(Val(Mid$(ean, iCount, 1))) Next iCount iAcc1 = 3 * iAcc1 iAcc = iAcc1 + iAcc2 + int(val(mid$(ean, 13, 1))) if iAcc mod 10 <> 0 then Function = %True else Function = %False end if End Function #endif