Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Bar Code wrapper

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Bar Code wrapper

    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
Working...
X