MODULO per BARCODE

Vi posto un piccolo regalo …
Un modulo che ritorna 3 tipologie di barcode ( Ean13-Ean8, Interleave 2di5, Code 39) in formato picture (immagine)

Function ean138p(codice as string, larghezza as integer, altezza as integer) As Picture
  Dim K As Single
  Dim sngPosX As Single
  Dim sngPosY As Single
  dim sngX1, sngY1, sngX2, sngY2 as single
  Dim sngScaleX As Single
  Dim strEANBin As String
  Dim p As New Picture (larghezza, altezza, 32)
  ' Converto il codice EAN nella sua rappresentazione binaria.
  
  strEANBin = EAN2Bin(codice)
  
  sngX1 = 10
  sngY1 = 0
  sngX2 = larghezza
  sngY2 = altezza -15
  
  sngScaleX = round(larghezza / strEANBin.Len)
  
  ' definisco l'altezza del barcode tenendo conto del testo
  sngPosX = sngX1 ' spigolo in alto
  sngPosY = sngY2
  '
  'disegno il barcode
  
  For K = 1 To Len(strEANBin)
    If Mid(strEANBin, K, 1) = "1" Then
      p.Graphics.ForeColor = &c000000
      p.Graphics.FillRect(sngPosX, sngY1, sngScaleX, sngPosY)
    End If
    sngPosX = sngX1 + (K * sngScaleX)
  Next K
  
  p.Graphics.DrawString(codice,sngX1,sngPosY + 15,sngX1 - sngX2,false)
  
  Return p
  
  
End Function

Function EAN2Bin(strEANCode As String) As string
  Dim K As Integer
  Dim strAux As String
  Dim strExit As String
  Dim strCode As String
  
  strEANCode = Trim(strEANCode)
  strAux = strEANCode
  
  ' verifico che sia un ean13 o un ean8 in base alla lunghezza della stringa strEANCode
  If (strAux.len <> 13) And (strAux.Len <> 8) Then
    msgbox("Errore, il codice non sembra essere un codice EAN13 o EAN8")
    Return ""
  End If
  
  For K = 1 To strEANCode.len
    Select Case mid(strAux,K,1)
    Case "0","1","2","3","4","5","6","7","8","9"
      ' ok il codice non contiene caratteri non validi
    case else
      MsgBox("Errore il codice EAN contiene caratteri non ammessi")
      'Return ""
    End Select
  Next
  
  
  If (strAux.len = 13) Then
    ' verifico che sia un EAN 13
    ' per prima cosa scarto la prima cifra che  lo stato di emissione (fare riferimento ad INDICOD '
    strAux = Mid(strAux, 2)
    Select Case CType(Val(Left(strEANCode, 1)), Integer)
    Case 0
      strCode = "000000"
    Case 1
      strCode = "001011"
    Case 2
      strCode = "001101"
    Case 3
      strCode = "001110"
    Case 4
      strCode = "010011"
    Case 5
      strCode = "011001"
    Case 6
      strCode = "011100"
    Case 7
      strCode = "010101"
    Case 8
      strCode = "010110"
    Case 9
      strCode = "011010"
    End Select
  Else
    strCode = "0000"
  End If
  
  '*
  '* Il codice EAN inizia con un carattere iniziale
  '*
  strExit = "000101"
  
  '*
  '* Prima met del codice
  '
  For K = 1 To Len(strAux) \\ 2
    
    select case CType(Val(Mid(strAux, K, 1)), Integer)
    Case 0
      dim temptext as string
      if Mid(strCode, K, 1) = "0" then temptext = "0001101" else temptext = "0100111"
      strExit = strExit + temptext
    Case 1
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0011001" else temptext = "0110011"
      strExit = strExit + temptext
      
    Case 2
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0010011" else temptext = "0011011"
      strExit = strExit + temptext
      
    Case 3
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0111101" else temptext = "0100001"
      strExit = strExit + temptext
      
    Case 4
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0100011" else temptext = "0011101"
      strExit = strExit + temptext
      
    Case 5
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0110001" else temptext = "0111001"
      strExit = strExit + temptext
      
    Case 6
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0101111" else temptext = "0000101"
      strExit = strExit + temptext
      
    Case 7
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0111011" else temptext = "0010001"
      strExit = strExit + temptext
      
    Case 8
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0110111" else temptext = "0001001"
      strExit = strExit + temptext
      
    Case 9
      dim temptext as string
      If Mid(strCode, K, 1) = "0" then temptext = "0001011" else temptext = "0010111"
      strExit = strExit + temptext
      
    End Select
  Next K
  
  '*
  '* Prosegue poi con un separatore di mezzo
  '*
  strExit = strExit + "01010"
  
  '*
  '* Seconda met del codice
  '*
  
  For K = Len(strAux) \\ 2 + 1 To Len(strAux)
    Select case CType(Val(Mid(strAux, K, 1)), Integer)
    Case 0
      strExit = strExit + "1110010"
    Case 1
      strExit = strExit + "1100110"
    Case 2
      strExit = strExit + "1101100"
    Case 3
      strExit = strExit + "1000010"
    Case 4
      strExit = strExit + "1011100"
    Case 5
      strExit = strExit + "1001110"
    Case 6
      strExit = strExit + "1010000"
    Case 7
      strExit = strExit + "1000100"
    Case 8
      strExit = strExit + "1001000"
    Case 9
      strExit = strExit + "1110100"
    End Select
  Next K
  
  
  ' Il Codice EAN finisce con un separatore finale
  
  strExit = strExit + "101000"
  
  return strExit
  
End Function

Function Code39(codice as string, altezza as integer) As Picture
  if codice.trim = "" then 
    Return nil
  end if
  // di default larghezza = 240 e altezza = 15 (millimetri)
  
  Dim contatore As Integer
  Dim sngPosX As Integer
  Dim sngPosY As Integer
  dim sngX1, sngY1, sngX2, sngY2 as Integer
  Dim sngScaleX As Integer
  dim dimensione as Integer
  Dim strEANBin As String
  dim strEANCode as string
  dim larghezza as integer
  
  if codice.left(1) <> "*" then codice = "*" + codice 
  if codice.Right(1) <> "*" then codice = codice + "*"
  
  sngScaleX = 1 // dimensione 0,21 mm per la barra singola;
  larghezza = sngScaleX * 16 * codice.Len
  
  Dim p As New Picture (larghezza, altezza, 32)
  
  strEANCode = codice
  sngX1 = 0
  sngX2 = larghezza
  sngY1 = 0
  sngY2 = altezza - 15
  
  ' Converto il codice EAN nella sua rappresentazione binaria.
  
  strEANBin = code392bin(strEANCode)
  ' calcolo la larghezza del codice 
  
  ' definisco l'altezza del barcode tenendo conto del testo
  sngPosX = sngX1 ' spigolo a sinistra
  sngPosY = sngY2 ' spigolo in basso
  
  'disegno il barcode con il colore corrente
  
  For contatore = 1 To Len(strEANBin)
    If Mid(strEANBin, contatore, 1) = "1" Then
      p.Graphics.ForeColor = &c000000
      p.Graphics.FillRect(sngPosX, sngY1, sngScaleX, sngPosY)
    End If
    sngPosX = sngX1 + (contatore * sngScaleX)
  Next contatore
  
  p.Graphics.DrawString(codice,sngX1,sngPosY + 15,sngX1 - sngX2,false)
  Return p
  
End Function

Function Code392Bin(strCode As String) As string
  Dim K As Integer
  Dim strAux As String
  Dim strExit As String
  
  strCode = Trim(strCode)
  strCode = Uppercase(strCode)
  strAux = strCode
  
  if strCode.trim = "" then return ""
  
  For K = 1 To strCode.len
    Select Case mid(strAux,K,1)
    Case "0","1","2","3","4","5","6","7","8","9","A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z","*","-","."," "
      ' ok il codice non contiene caratteri non validi
    case else
      MsgBox("Errore il codice 39 contiene caratteri non ammessi, sono ammessi caratteri 0-9, A-Z, *,-,., ")
      Return ""
    End Select
  Next
  
  // se il codice non comincia con '*' e finisce con '*' allora ce li mettiamo
  if strCode.left(1) <> "*" then strCode = "*" + strCode 
  if strCode.Right(1) <> "*" then strCode = strCode + "*"
  
  For K = 1 To strCode.len
    Select Case Mid(strCode, K, 1)
    Case "1"
      strExit = strExit + "1110100010101110"
    Case "2"
      strExit = strExit + "1011100010101110"
    Case "3"
      strExit = strExit + "1110111000101010"
    Case "4"
      strExit = strExit + "1010001110101110"
    Case "5"
      strExit = strExit + "1110100011101010"
    Case "6"
      strExit = strExit + "1011100011101010"
    Case "7"
      strExit = strExit + "1010001011101110"
    Case "8"
      strExit = strExit + "1110100010111010"
    Case "9"
      strExit = strExit + "1011100010111010"
    Case "0"
      strExit = strExit + "1010001110111010"
    Case "A"
      strExit = strExit + "1110101000101110"
    Case "B"
      strExit = strExit + "1011101000101110"
    Case "C"
      strExit = strExit + "1110111010001010"
    Case "D"
      strExit = strExit + "1010111000101110"
    Case "E"
      strExit = strExit + "1110101110001010"
    Case "F"
      strExit = strExit + "1011101110001010"
    Case "G"
      strExit = strExit + "1010100011101110"
    Case "H"
      strExit = strExit + "1110101000111010"
    Case "I"
      strExit = strExit + "1011101000111010"
    Case "J"
      strExit = strExit + "1010111000111010"
    Case "K"
      strExit = strExit + "1110101010001110"
    Case "L"
      strExit = strExit + "1011101010001110"
    Case "M"
      strExit = strExit + "1110111010100010"
    Case "N"
      strExit = strExit + "1010111010001110"
    Case "O"
      strExit = strExit + "1110101110100010"
    Case "P"
      strExit = strExit + "1011101110100010"
    Case "Q"
      strExit = strExit + "1010101110001110"
    Case "R"
      strExit = strExit + "1110101011100010"
    Case "S"
      strExit = strExit + "1011101011100010"
    Case "T"
      strExit = strExit + "1010111011100010"
    Case "U"
      strExit = strExit + "1110001010101110"
    Case "V"
      strExit = strExit + "1000111010101110"
    Case "W"
      strExit = strExit + "1110001110101010"
    Case "X"
      strExit = strExit + "1000101110101110"
    Case "Y"
      strExit = strExit + "1110001011101010"
    Case "Z"
      strExit = strExit + "1000111011101010"
    Case "*"
      strExit = strExit + "1000101110111010"
    Case "-"
      strExit = strExit + "1000101011101110"
    Case "."
      strExit = strExit + "1110001010111010"
    Case " "
      strExit = strExit + "1000111010111010"
    case else
      // salto
    End Select
  Next K
  
  
  ' Il Codice EAN finisce con un separatore finale
  
  strExit = strExit
  
  return strExit
  
End Function

Function EAN13checkdigit(stringpart as string) As string
  Dim strParts() As String
  Dim lngIndex As integer
  Dim intTotal As Integer
  Dim intCount As Integer
  Dim intUp As Integer
  
  select case len(stringpart)
  case 7,12
    // procedo
  case 8,13
    Return stringpart
  case else
    Return ""
  end select
  
  stringpart = stringpart + "C"
  strParts = Split(stringpart, "")
  
  For lngIndex = UBound(strParts) - 1 To 0 Step -2
    For intCount = 1 To 3
      intTotal = intTotal + CType(Val(strParts(lngIndex)), Integer)
    Next
  Next
  
  For lngIndex = UBound(strParts) To 0 Step -2
    intTotal = intTotal + CType(Val(strParts(lngIndex)), Integer)
  Next
  
  intUp = intTotal
  Do Until intUp Mod 10 = 0
    intUp = intUp + 1
  Loop
  
  strParts(UBound(strParts)) = str(intUp - intTotal)
  
  return join(strParts(),"")
End Function

Function Interleave2of52bin(strCode As String) As string
  Dim K As Integer
  Dim strAux As String
  Dim strExit As String
  
  strCode = Trim(strCode)
  strCode = Uppercase(strCode)
  strAux = strCode
  
  if strCode.trim = "" then return ""
  
  For K = 1 To strCode.len
    Select Case mid(strAux,K,1)
    Case "0","1","2","3","4","5","6","7","8","9","@","§"
      ' ok il codice non contiene caratteri non validi
    case else
      MsgBox("Errore il codice interleave 2 of 5 contiene caratteri non ammessi, sono ammessi solo numeri da 0-9")
      Return ""
    End Select
  Next
  
  For K = 1 To strCode.len
    Select Case Mid(strCode, K, 1)
    Case "1"
      strExit = strExit + "11010010010110"
    Case "2"
      strExit = strExit + "11010101001100"
    Case "3"
      strExit = strExit + "11001010100110"
    Case "4"
      strExit = strExit + "11010010100110"
    Case "5"
      strExit = strExit + "10110100100110"
    Case "6"
      strExit = strExit + "10011010101100"
    Case "7"
      strExit = strExit + "10110010101100"
    Case "8"
      strExit = strExit + "10011001010110"
    Case "9"
      strExit = strExit + "10110100101100"
    Case "0"
      strExit = strExit + "11001010010110"
    Case "@"
      strExit = strExit + "10110010110010"
    Case "§"
      strExit = strExit + "11010000000000"
    case else
      // salto
    End Select
  Next K
  
  
  ' Il Codice EAN finisce con un separatore finale
  
  strExit = strExit
  
  return strExit

End Function

Function Interleave2of5(codice as string, altezza as integer) As picture
  // se ho inviato un codice vuoto esco
  if codice.trim = "" then 
    Return nil
  end if
  // se nel codice ci sono solo numeri continuo
  Dim contatore As Integer
  dim codicetemp as String = ""
  dim operazione as integer
  operazione = codice.len
  if (operazione mod 2) <> 0 then 
    codice = "0" + codice 
  end if
  
  for contatore = 0 to codice.len
    dim k as string = mid(codice,contatore,1)
    select case k
    case "0","1","2","3","4","5","6","7","8","9"
      codicetemp = codicetemp + k
    end select
  next contatore
  
  codice = codicetemp
  codicetemp = "@" + codicetemp + "§"
  
  Dim sngPosX As Integer
  Dim sngPosY As Integer
  dim sngX1, sngY1, sngX2, sngY2 as Integer
  Dim sngScaleX As Integer
  dim dimensione as Integer
  Dim strEANBin As String
  dim strEANCode as string
  dim larghezza as Integer
  
  sngScaleX = 1 // dimensione 0,21 mm per la barra singola;
  larghezza = sngScaleX * 14 * (codice.Len + 2) 
  
  Dim p As New Picture (larghezza, altezza, 32)
  
  strEANCode = codicetemp
  sngX1 = 0
  sngX2 = larghezza
  sngY1 = 0
  sngY2 = altezza - 15
  
  ' Converto il codice EAN nella sua rappresentazione binaria.
  
  strEANBin = Interleave2of52bin(strEANCode)
  ' calcolo la larghezza del codice 
  
  If sngX1 = (-1) Then sngX1 = 0
  If sngY1 = (-1) Then sngY1 = 0
  If sngX2 = (-1) Then sngX2 = larghezza
  If sngY2 = (-1) Then sngY2 = altezza
  
  ' definisco l'altezza del barcode tenendo conto del testo
  sngPosX = sngX1 ' spigolo a sinistra
  sngPosY = sngY2 ' spigolo in basso
  
  'disegno il barcode con il colore corrente
  
  For contatore = 1 To Len(strEANBin)
    If Mid(strEANBin, contatore, 1) = "1" Then
      p.Graphics.ForeColor = &c000000
      p.Graphics.FillRect(sngPosX, sngY1, sngScaleX, sngY2)
    End If
    sngPosX = sngX1 + (contatore * sngScaleX)
  Next contatore
  
  p.Graphics.DrawString(codice,sngX1,sngPosY + 15,sngX1 - sngX2,false)
  
  Return p
End Function

Ciao Massimiliano,
Ho provato il tuo codice relativo al barcode Ean13, funziona perfettamente, ho provato a stamparlo (stampa schermo di quello che appare nel container control) ma il lettore di barcode non lo legge e neanche il cellulare.
Tu hai fatto qualche prova? Ti funziona?
Grazie
P.s. Scusa ho postato qui, ma mi riferivo al post ean13 semplice semplice