Bar Code wrapper

Don Dickinson

Member

Join Date: Nov 2002
Posts: 1950

1 Jun 2001, 12:50 PM

Below is a re-work of the bar-code wrapper initially posted by David J Walker. I cleaned it up a bit (explitly declared all variables so it would compile with #dim all, etc). I also changed the call interface to better suit my liking. I don't have a barcode scanner to test with so if anyone wants to check it out, I'd be much appreciative. At the bottom is a short ddoc program that will print a barcode - if you own ddoc or download the eval from dickinson.basicguru.com you can print a bar code with it.

Code:

'
'  pb_bar.bas
'
'  Barcode generation Adapted for pbcc/pbdll 
'  by Don Dickinson
'  [email protected]
'  
'  Adapted from David J Walker's Public Domain Code
'  as posted at [url="http://www.powerbasic.com"]www.powerbasic.com[/url]  in the support forums code area
'
'     David J Walker
'     [email protected]
'     
'
'  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!
'
'  Dependencies:
'     None. 
'     %True and %False are defined if not already defined.
'
'  Function:
'     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
'
'  Note:
'     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

And the pbdll6 program that prints a bar code with ddoc.

Code:

'
'  testbar.bas
'
'  Here are the barcode type constants
'  %BC_TYPE_UPC            = 0
'  %BC_TYPE_ITF            = 1
'  %BC_TYPE_39             = 2
'  %BC_TYPE_EAN8           = 3
'  %BC_TYPE_EAN13          = 4
'
#compile exe
#dim all

#include "win32api.inc"
#include "pb_bar.bas"
#include "ddoc_p32.inc"

Function PBMain()

   Dim hPrev as Integer
   Dim i as Long
   Dim cx as Single
   Dim lw as Single
   Dim bc as String
   
   hPrev = dpStartDoc(0, "Test", "", %DDOC_INCH, %DDOC_PAPER_LETTER, %DDOC_PORTRAIT, %DDOC_BIN_AUTO, %DDOC_ZOOMFIT)
   if hPrev then
      bc = pbBarCode(%BC_TYPE_UPC, "1234560", %True)
      lw = .02    '50 lines per inch
      cx = 3
      
      'MsgBox bc + $cr + "width=" + format$(len(bc))
      For i = 1 to len(bc)
         cx = cx + lw  
         if mid$(bc, i, 1) = "1" then
            dpRect hPrev, cx, 1, cx + lw, 2, 0, 0, 0
         end if
      Next i 
      dpEndDoc hPrev, %DDOC_END_VIEW + %DDOC_END_DELETE
   end if
   
End Function

Best Regards,
Don

------------------
dickinson.basicguru.com

Don Dickinson
www.greatwebdivide.com

Tags: None

Previous template Next

Announcement

Forum Guidelines

Bar Code wrapper

Bar Code wrapper