Code barre suivant la norme ean-13


Télécharger le projet
Commenter

Description

Voir le fichier zip

Source / Exemple : 


' 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
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (Zlub)