0/5 (9 avis)
Vue 24 317 fois - Téléchargée 2 818 fois
' 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
9 oct. 2007 à 12:13
Peut-on enregistrer le code barre au format image ?
4 janv. 2007 à 05:50
parce que ça fais des choses bizard.....
mais sinon super truc.... merci encore....
@+ Sator
27 juil. 2005 à 03:22
12 déc. 2003 à 12:54
Je voulais savoir qqch, j'aimerais imprimer avec une imprimante spéciale pour créer des étiquette (smart label 100).
Mais quand je veux imprimer, cela me mets une erreur.
Goldfingers
14 nov. 2003 à 12:09
Juste une petite question/suggestion :
j'aimerais récupérer le code barre généré et le placer dans un document Word.
J'ai essayé de faire une copie de la picturebox (piccodebarre) , mais il ne me copie rien ?
Avez vous une suggestion pour que cela fonctionne ??
Merci d'avance,
Cyclone
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.