CODE BARRE SUIVANT LA NORME EAN-13

' Fonction d'impression du code barre < Full Option >
Public Sub CodeBarre_Impression(CodeBarre As String, PictureLogo As PictureBox, _
                                 Optional ImprimerTxt As Boolean = True, _
                                 Optional CalibrageTrait As Integer = 2)

'    CodeBarre      = valeur du code barre
'    PictureLogo    = PictureBox contenant l'image placée à cotée du code barre
'    ImprimerTxt    = definit s'il faut imprimer les textes
'    CalibrageTrait = calibre l'epaisseur du trait en fonction de l'imprimante

    Dim MaskBinaire As String
    
    '=== Calcul du caractère de contrôle.
    CodeBarre = CalculNumControlCodeBarre(CodeBarre)

    '=== Génération du mask "binaire"
    MaskBinaire = EAN13_Binaire(CodeBarre)
    
    Call CodeBarre_Imp(MaskBinaire, PictureLogo, CalibrageTrait)
    
    If ImprimerTxt Then
        Call CodeBarreTxt(CodeBarre)
    End If
    
    Printer.EndDoc
    
End Sub
' Fonction de visualisation du code barre < Full Option >
Public Sub CodeBarre_Image(CodeBarre As String, PictureCodeBarre As PictureBox, PictureLogo As PictureBox)

    Dim MaskBinaire As String
    
    '=== Calcul du caractère de contrôle.
    CodeBarre = CalculNumControlCodeBarre(CodeBarre)

    '=== Génération du mask "binaire"
    MaskBinaire = EAN13_Binaire(CodeBarre)
    
    Call CodeBarre_Pict(MaskBinaire, PictureCodeBarre, PictureLogo)
    Call CodeBarreLegende(CodeBarre, PictureCodeBarre)
    
End Sub


'*****************************************************************************
'
'       P.e.f  outils pour traiter et generer les codes barres
'
'*****************************************************************************

'Conversion du code barre en chiffre -> mask Binaire
Public Function EAN13_Binaire(ByVal CodeBar As String) As String
    '// CodeBar=code 13 chiffres à convertir en "binaire"
    '//==== "0" = une bande blanche
    '//==== "1" = une bande noire
    '//==== "-" = décrementer la hauteur de la barre de <HautDec>
    '//==== "+" = Incrementer la hauteur de la barre de <HautDec>
    
    Dim TJA(10)         As String
    Dim TJB(10)         As String
    Dim TJC(10)         As String
    Dim Tcontrol(10)    As String
    Dim Chiffre         As Long
    Dim ind             As Long
    Dim Inverseur       As String   ' Pour inversion suivant le type de code
    Dim CodeChiffre     As String   ' Profil binaire des traits
    Dim TypeCode        As Long     ' Premier caractère du code barre
        
        
    ' Initialisation du jeu de caractères pour code barre EAN-13
    TJA(1) = "0001101"
    TJA(2) = "0011001"
    TJA(3) = "0010011"
    TJA(4) = "0111101"
    TJA(5) = "0100011"
    TJA(6) = "0110001"
    TJA(7) = "0101111"
    TJA(8) = "0111011"
    TJA(9) = "0110111"
    TJA(10) = "0001011"
    
    TJB(1) = "0100111"
    TJB(2) = "0110011"
    TJB(3) = "0011011"
    TJB(4) = "0100001"
    TJB(5) = "0011101"
    TJB(6) = "0111001"
    TJB(7) = "0000101"
    TJB(8) = "0010001"
    TJB(9) = "0001001"
    TJB(10) = "0010111"
    
    TJC(1) = "1110010"
    TJC(2) = "1100110"
    TJC(3) = "1101100"
    TJC(4) = "1000010"
    TJC(5) = "1011100"
    TJC(6) = "1001110"
    TJC(7) = "1010000"
    TJC(8) = "1000100"
    TJC(9) = "1001000"
    TJC(10) = "1110100"
    
    Tcontrol(1) = "AAAAAA"
    Tcontrol(2) = "AABABB"
    Tcontrol(3) = "AABBAB"
    Tcontrol(4) = "AABBBA"
    Tcontrol(5) = "ABAABB"
    Tcontrol(6) = "ABBAAB"
    Tcontrol(7) = "ABBBAA"
    Tcontrol(8) = "ABABAB"
    Tcontrol(9) = "ABABBA"
    Tcontrol(10) = "ABBABA"
    
    ' Extrait le premier caractère: type de code, non imprimé sous forme de barre
    TypeCode = Val(Mid(CodeBar, 1, 1))
    Inverseur = Tcontrol(TypeCode + 1) ' Inversera certains profils
    CodeBar = Mid(CodeBar, 2, 12) ' Il reste 11 caractères

    
    '//==== Creation du mask représentant le code barre (série de 1, de 0, de + et de -)
    
    '============== GUARD PATTERN
    CodeChiffre = "101-"
    
    '============== ODD PARITY
    For ind = 1 To 6
        Chiffre = Mid(Trim(CodeBar), ind, 1)
        If Mid(Inverseur, ind, 1) = "A" Then
            CodeChiffre = CodeChiffre & (TJA(Chiffre + 1))
        Else
            CodeChiffre = CodeChiffre + (TJB(Chiffre + 1))
        End If
    Next ind
    
    '============== MIDDLE GUARD PATTERN
    CodeChiffre = CodeChiffre + "+01010-"
    
    '============== EVEN PARITY
    For ind = 7 To 12
        Chiffre = Val(Mid(CodeBar, ind, 1))
        CodeChiffre = CodeChiffre + TJC(Chiffre + 1)
    Next ind
    
    '============== GUARD PATTERN
    CodeChiffre = CodeChiffre + "+101"
    
    'Return de la fonction de conversion en "binaire"
    EAN13_Binaire = CodeChiffre
End Function
'Fonction de calcul du caractere de controle et renvoi le code complet
Public Function CalculNumControlCodeBarre(pCodeBar As String) As String
    Dim ind         As Long
    Dim CarControl  As Long ' Caractère de contrôle
    Dim TypeCode    As Long ' Premier caractère du code barre
    
    ' Extrait le premier caractère: type de code, non imprimé sous forme de barre
    TypeCode = Val(Mid(pCodeBar, 1, 1))
    pCodeBar = Mid(pCodeBar, 2, 11) ' Il reste 11 caractères
    
    '=== Calcul du caractère de contrôle.
    CarControl = TypeCode
    For ind = 1 To 11
        If ind Mod 2 <> 0 Then
            CarControl = CarControl + Val(Mid(pCodeBar, ind, 1)) * 3 ' Controle*3
        Else
            CarControl = CarControl + Val(Mid(pCodeBar, ind, 1))
        End If
    Next ind
    CarControl = ((Int((CarControl - 1) / 10) + 1) * 10) - CarControl
    
    'renvoi le code barre complet
    CalculNumControlCodeBarre = TypeCode & CStr(Mid(pCodeBar, 1, 6)) & CStr(Mid(pCodeBar, 7, 5)) + CStr(CarControl)
End Function
'test la validité du code barre
Public Function CheckSumValide(CodeBarre As String) As Boolean
    ' CodeBarre = code barre a tester
    
    Dim ind         As Integer
    Dim CarControl  As Long     ' Caractère de contrôle
    Dim TypeCode    As Long     ' Premier caractère du code barre
    Dim CheckSum    As Integer  ' Dernier caractere
    
    ' Extrait le premier caractère: type de code, non imprimé sous forme de barre
    TypeCode = Val(Mid(CodeBarre, 1, 1))
    CheckSum = Val(Mid(CodeBarre, 13, 1))
    CodeBarre = Mid(CodeBarre, 2, 11) ' Il reste 11 caractères
    
    '=== Calcul du caractère de contrôle.
    CarControl = TypeCode
    For ind = 1 To 11
        If ind Mod 2 <> 0 Then
            CarControl = CarControl + Val(Mid(CodeBarre, ind, 1)) * 3 ' Controle*3
        Else
            CarControl = CarControl + Val(Mid(CodeBarre, ind, 1))
        End If
    Next ind
    CarControl = ((Int((CarControl - 1) / 10) + 1) * 10) - CarControl

    CheckSumValide = (CheckSum = CarControl)
End Function
'Visualisation dans une PictureBox du code barre
Public Sub CodeBarre_Pict(MaskCodeBarre As String, Picture As PictureBox, _
                          Logo As PictureBox, _
                          Optional nHauteur As Long = 600, Optional nLargeur As Long = 35, _
                          Optional nHautDec As Long = 40, Optional Col As Long = 100, _
                          Optional Lig As Long = 100)
    '// Col,Lig         = Position dans la Picturebox
    '// nHauteur        = Hauteur du code barre
    '// nLargeur        = Largeur du code barre
    '// nHautDec        = Hauteur supplémentaires des traits de séparation
    '// MaskCodeBarre   = Profil binaire sous forme de "0" et "1" à imprimer
    '// Logo            = PictureBox contenant le logo de l'entreprise


    Dim NumCar          As Long     ' Position dans le mask "binaire
    Dim NbTrait         As Long     ' Nb de lignes à tracer
    Dim Epaisseur1Trait As Double   ' Epaisseur d'un trait
    Dim i               As Integer  ' Indice de boucle
    Dim X               As Double   ' Abscisse de la ligne à tracer dans la PictureBox
    Dim nLen            As Long     ' Taille du mask "binaire"

    'Efface l'image existante
    Picture.Cls
    
    ' Nombre de caractères à analyser
    nLen = Len(MaskCodeBarre)
        
    ' Calcul de l'épaisseur d'un trait suivant la largeur demandée et le nombre de traits
    ' On comptabilise les caractères "+" et "-" même s'ils ne sont pas imprimés (négligeable)
    Epaisseur1Trait = 15
    

    X = Col + Epaisseur1Trait * 7 ' Décalage vers la gauche pour le chiffre affiché dessous
    
    NumCar = 1
    'Generation des lignes
    Do While NumCar <= nLen
        Select Case Mid(MaskCodeBarre, NumCar, 1)
            Case "-" ' Indicateur de diminution de hauteur de barre...
                nHauteur = nHauteur - nHautDec
                NumCar = NumCar + 1
            Case "+" ' Indicateur d'augmentation de hauteur de barre...
                nHauteur = nHauteur + nHautDec
                NumCar = NumCar + 1
            Case "0" ' Espace
                X = X + Epaisseur1Trait
                NumCar = NumCar + 1
            Case "1" ' Barre
            'Regroupe tous les '1' successif du mask "binaire" pour gagner du temps
                NbTrait = 0
                Do While Mid(MaskCodeBarre, NumCar, 1) = "1"
                    NbTrait = NbTrait + 1
                    NumCar = NumCar + 1
                Loop
                
                'Definition de l'épaisseur du trait des barres
                Picture.DrawWidth = 1
                
                'Tarce les lignes dans la PictureBox
                For i = 1 To NbTrait
                    Picture.Line (X, Lig)-(X, Lig + nHauteur)
                    X = X + Epaisseur1Trait
                Next i
        End Select
    Loop
    Picture.CurrentX = Picture.CurrentX + 500
    Call Picture.PaintPicture(Logo, Picture.CurrentX + 150, 150)
    
End Sub
'Impressions
Public Sub CodeBarre_Imp(MaskCodeBarre As String, PictureLogo As PictureBox, _
                            Optional CalibrageTrait As Integer = 2, _
                            Optional nHauteur As Long = 600, Optional nLargeur As Long = 35, _
                            Optional nHautDec As Long = 40, Optional Col As Long = 100, _
                            Optional Lig As Long = 100)
    '// Impression des traits
    '// Col,Lig         = Position pour l'impression
    '// nHauteur        = Hauteur du code barre
    '// nLargeur        = Largeur du code barre
    '// nHautDec        = Hauteur supplémentaires des traits de séparation
    '// MaskCodeBarre   = profil binaire sous forme de "0" et "1" à imprimer
    '// PictureLogo     = Logo à imprimer à coté du code barre
    '// CalibrageTrait  = Epaisseur du trait pour l'imprimante (dépendant de la résolution de celle-ci
    '//                    300*300 dpi : 4  --------  180*180 dpi  (thermique) : 2 )
    '//
    '//
    '//
    ' ATTENTTION : il faut une PictureBox dans la frame appelante : Picture1
    ' ----------
    
    Dim NumCar          As Long     ' Position dans le mask "binaire
    Dim NbTrait         As Long     ' Nb de lignes à tracer
    Dim i               As Integer  ' Indice de boucle
    Dim X               As Double   ' Abscisse de la ligne à tracer dans la PictureBox
    Dim nLen            As Long     ' Taille du mask "binaire"
    Dim Epaisseur1Trait As Integer  ' Epaisseur d'un trait
   
   
   Epaisseur1Trait = 16
   nLen = Len(MaskCodeBarre) ' Nombre de caractères à analyser
    
    ' Définition de la marge d'impression
    X = Col + Epaisseur1Trait * 7
    
    NumCar = 1
  'Generation des lignes
    Do While NumCar <= nLen
        Select Case Mid(MaskCodeBarre, NumCar, 1)
            Case "-" ' Indicateur de diminution de hauteur de barre...
                nHauteur = nHauteur - nHautDec
                NumCar = NumCar + 1
            Case "+" ' Indicateur d'augmentation de hauteur de barre...
                nHauteur = nHauteur + nHautDec
                NumCar = NumCar + 1
            Case "0" ' Espace
                X = X + Epaisseur1Trait
                NumCar = NumCar + 1
            Case "1" ' Barre
            'Regroupe tous les '1' successif du mask "binaire" pour gagner du temps
                NbTrait = 0
                Do While Mid(MaskCodeBarre, NumCar, 1) = "1"
                    NbTrait = NbTrait + 1
                    NumCar = NumCar + 1
                Loop
                
                'Definition de l'épaisseur du trait des barres
                Printer.DrawWidth = CalibrageTrait
                
                For i = 1 To NbTrait
                    Printer.Line (X, Lig)-(X, Lig + nHauteur)
                    X = X + Epaisseur1Trait
                Next i
        End Select
    Loop
    
    Call Printer.PaintPicture(PictureLogo, X + 500, 100)
End Sub
' Procedure ajoutant un texte sous le code barre
Public Sub CodeBarreTxt(CodeBarre As String, _
                        Optional txt As String = "Garantie nulle sans cette étiquette", _
                        Optional NomPolice As String = "verdana", _
                        Optional TaillePolice As Integer = 7, _
                        Optional DecalTxt As Integer = 300)
                        
    '// CodeBarre   = Valeur du code barre
    '// txt         = texte à afficher sous le code barre
    '// DecalTxt    = marge du texte à afficher sous le code barre


    'Déplace le pointeur de l'imprimante
    Printer.CurrentX = 200
    Printer.FontName = NomPolice
    Printer.FontSize = TaillePolice
    
    'Mise en forme du code barre : mise en place d'espaces
    Printer.Print CodeBarre_TxtFormate_Printer(CodeBarre)
    Printer.CurrentX = Printer.CurrentX + DecalTxt
    Printer.Print txt
End Sub
Public Sub CodeBarreLegende(CodeBarre As String, PictureCodeBarre As PictureBox, _
                        Optional txt As String = "Garantie nulle sans cette étiquette", _
                        Optional NomPolice As String = "verdana", _
                        Optional TaillePolice As Integer = 7, _
                        Optional DecalTxt As Integer = 300)
                        
    '// CodeBarre   = Valeur du code barre
    '// txt         = texte à afficher sous le code barre
    '// DecalTxt    = marge du texte à afficher sous le code barre

    'Déplace le pointeur de l'imprimante
    PictureCodeBarre.CurrentX = 200
    PictureCodeBarre.FontName = NomPolice
    PictureCodeBarre.FontSize = TaillePolice
    
    'Mise en forme du code barre : mise en place d'espaces
    PictureCodeBarre.Print CodeBarre_TxtFormate_Image(CodeBarre)
    PictureCodeBarre.CurrentX = Printer.CurrentX + DecalTxt
    PictureCodeBarre.Print txt
End Sub
'Mises en forme du texte sous le code barre
Public Function CodeBarre_TxtFormate_Printer(CodeBarre As String) As String
    '// format de presentation :  1  234567  890128
    CodeBarre_TxtFormate_Printer = CStr(Mid(CodeBarre, 1, 1)) & "  " & CStr(Mid(CodeBarre, 2, 6)) & "   " & CStr(Mid(CodeBarre, 8, 6))
End Function
Public Function CodeBarre_TxtFormate_Image(CodeBarre As String) As String
    '// format de presentation :  1  234567  890128
    CodeBarre_TxtFormate_Image = CStr(Mid(CodeBarre, 1, 1)) & " " & CStr(Mid(CodeBarre, 2, 6)) & " " & CStr(Mid(CodeBarre, 8, 6))
End Function