Créer des codes-barres 128 en VBA

Je précise que je travaille sous Access 2010

Voici le code que j'ai simplement copié sur le tuto :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
 
Option Compare Database
 
Option Explicit
 
'Déclaration des variables publiques
'Mode de traçage des colonnes de l'état
Public lngTracageColonne As Long
'Type de hauteur du code-barre : fixe ou variable
Public strHauteurCodeBarres
'Hauteur des modules de barre ou d'espace (twips)
Public lngHauteurModule As Long
'Largeur des modules de barre ou d'espace (twips)
Public lngTailleModule As Long
'Largeur du code-barres (twips)
Public lngLargeurCodeBarres As Long
'Déclaration des constantes utilisées dans le module
'Couleur des barres
Private Const CouleurBarre As Long = 0
'Couleur des espaces
Private Const CouleurEspace As Long = 16777215
 
Function Code128(strChaine)
 
'Caractère en cours de traitement
Dim strCaractere As String
'Chaîne de caractères temporaire
Dim strChaineTemp As String
'Caractère temporaire en cours de traitement
Dim strCarTemp As String
'Table utilisée (table B)
Dim blnTableB As Boolean
'Table utilisée (table C)
Dim blnTableC As Boolean
'Valeur de la clé de contrôle
Dim lngCaractereControle As Long
'Variable de compteur
Dim i As Long
'Variable de compteur
Dim j As Long
 
    On Error GoTo GestionErreurs
 
    'Génération d'une erreur définie par l'utilisateur
    If IsNull(strChaine) Then Err.Raise 513
 
    'Codage de la chaîne de caractères
    For i = 1 To Len(strChaine)
 
        'Extraction d'un caractère de la chaîne
        strCaractere = Mid(strChaine, i, 1)
 
        'Ajout du caractère à la chaîne temporaire
        strChaineTemp = strChaineTemp & strCaractere
 
        'Début sur table B ou C
        If Not blnTableB And Not blnTableC Then
 
            'Quatre caractères numériques sont nécessaires pour débuter en table C
            If IsNumeric(strCaractere) Then
 
                'La chaîne temporaire contient quatre caractères numériques, début sur table C
                If Len(strChaineTemp) = 4 Then
 
                    'Ajout du caractère de démarrage de la table C
                    Code128 = Chr(210)
 
                    'Traitement de quatre caractères. Ajout de deux caractères optimisés
                    For j = 1 To 4 Step 2
                        strCarTemp = Val(Mid(strChaineTemp, j, 2))
                        strCarTemp = IIf(strCarTemp < 95, strCarTemp + 32, strCarTemp + 105)
                        Code128 = Code128 & Chr(strCarTemp)
                    Next j
 
                    'Purge de la chaîne de caractères temporaire
                    strChaineTemp = ""
 
                    'La table C est utilisée
                    blnTableC = True
 
                End If
 
            'Le nombre de caractères numériques en début de chaîne est inférieur à quatre, début sur table B
            Else
 
                'Ajout du caractère de démarrage de la table B
                Code128 = Code128 & Chr(209)
 
                'Ajout des caractères de la chaîne temporaire
                For j = 1 To Len(strChaineTemp)
                    Code128 = Code128 & Mid(strChaineTemp, j, 1)
                Next j
 
                'Purge de la chaîne de caractères temporaire
                strChaineTemp = ""
 
                'La table B est utilisée
                blnTableB = True
 
            End If
 
        'Traitement de la suite de la chaîne de caractères
        Else
 
            'Traitement sur table C, tentative de traiter des caractères numériques supplémentaires
            If blnTableC Then
 
                'Deux caractères numériques sont nécessaires pour continuer sur table C
                If IsNumeric(strCaractere) Then
 
                    'La chaine temporaire contient deux caractères numériques
                    If Len(strChaineTemp) = 2 Then
 
                        'Traitement de deux caractères. Ajout d'un caractère optimisé
                        strCarTemp = Val(Mid(strChaineTemp, 1, 2))
                        strCarTemp = IIf(strCarTemp < 95, strCarTemp + 32, strCarTemp + 105)
                        Code128 = Code128 & Chr(strCarTemp)
 
                        'Purge de la chaîne de caractères temporaire
                        strChaineTemp = ""
 
                    End If
 
                'Le nombre de caractères numériques est inférieur à deux
                Else
 
                    'Permutation sur table B
                    Code128 = Code128 & Chr(205)
 
                    'Ajout des caractères de la chaîne temporaire
                    For j = 1 To Len(strChaineTemp)
                        Code128 = Code128 & Mid(strChaineTemp, j, 1)
                    Next j
 
                    'Purge de la chaîne de caractères temporaire
                    strChaineTemp = ""
 
                    'La table B est utilisée
                    blnTableC = False
                    blnTableB = True
 
                End If
 
            'Traitement sur table B, tentative de permuter sur table C pour optimiser le code
            Else
 
                'Le caractère est numérique
                If IsNumeric(strCaractere) Then
 
                    'Si le reste de la chaîne et le contenu de la chaîne temporaire est égal
                    'à au moins six caractères
                    If Len(strChaine) - i + Len(strChaineTemp) >= 6 Then
 
                        'La chaîne temporaire contient six caractères numériques
                        If Len(strChaineTemp) = 6 Then
 
                            'Permutation sur table C
                            Code128 = Code128 & Chr(204)
 
                            'Traitement de six caractères numériques. Ajout de trois caractères optimisés
                            For j = 1 To 6 Step 2
                                strCarTemp = Val(Mid(strChaineTemp, j, 2))
                                strCarTemp = IIf(strCarTemp < 95, strCarTemp + 32, strCarTemp + 105)
                                Code128 = Code128 & Chr(strCarTemp)
                            Next j
 
                            'Purge de la chaîne de caractères temporaire
                            strChaineTemp = ""
 
                            'La table C est utilisée
                            blnTableB = False
                            blnTableC = True
 
                        End If
 
                    'Le nombre de caractères de la chaîne temporaire et le reste de caractères à traiter est inférieur à six
                    Else
 
                        'Le reste de caractères à traiter est égal à cinq
                        If Len(strChaine) - i + 1 = 5 Then
 
                            'Ajout du caractère sur table B
                            Code128 = Code128 & strChaineTemp
 
                            'Purge de la chaîne de caractères temporaire
                            strChaineTemp = ""
 
                        End If
 
                        'Si le nombre de caractères restant est égal ou inférieur à quatre
                        If Len(strChaine) - i + 1 <= 4 Then
 
                            'La chaîne temporaire contient quatre caractères numériques
                            If Len(strChaineTemp) = 4 Then
 
                                'Permutation sur table C
                                Code128 = Code128 & Chr(204)
 
                                'Traitement de quatre caractères numériques. Ajout de deux caractères optimisés
                                    For j = 1 To 4 Step 2
                                    strCarTemp = Val(Mid(strChaineTemp, j, 2))
                                    strCarTemp = IIf(strCarTemp < 95, strCarTemp + 32, strCarTemp + 105)
                                    Code128 = Code128 & Chr(strCarTemp)
                                Next j
 
                                'Purge de la chaîne de caractères temporaire
                                strChaineTemp = ""
 
                            End If
 
                        End If
 
                    End If
 
                'Le caractère en cours n'est pas numérique
                Else
 
                    'Ajout du caractère sur table B
                    For j = 1 To Len(strChaineTemp)
                        Code128 = Code128 & Mid(strChaineTemp, j, 1)
                    Next j
 
                    'Purge de la chaîne de caractères temporaire
                    strChaineTemp = ""
 
                End If
 
            End If
 
        End If
 
        'Traitement du dernier caractère de la chaîne
        If i = Len(strChaine) And Len(strChaineTemp) >= 1 Then
 
            'La table C est en cours d'utilisation
            If blnTableC Then
 
                'Permutation vers la table B
                Code128 = Code128 & Chr(205)
 
                'Ajout du dernier caractère sur table B
                Code128 = Code128 & strChaineTemp
 
            'La table B est en cours d'utilisation
            ElseIf blnTableB Then
 
                'Ajout des caractères de la chaîne temporaire
                For j = 1 To Len(strChaineTemp)
                    Code128 = Code128 & Mid(strChaineTemp, j, 1)
                Next j
 
            'Aucune des deux tables n'est utilisée. La chaîne de caractères contient moins
            'de quatre caractères numériques
            Else
 
                'Début sur table B
                Code128 = Code128 & Chr(209)
 
                'Ajout des caractères de la chaîne temporaire
                For j = 1 To Len(strChaineTemp)
                    Code128 = Code128 & Mid(strChaineTemp, j, 1)
                Next j
 
            End If
 
        End If
 
    Next i
 
    'Calcul de la valeur de la clé de contrôle
    For j = 1 To Len(Code128)
        strCarTemp = Asc(Mid(Code128, j, 1))
        strCarTemp = IIf(strCarTemp < 127, strCarTemp - 32, strCarTemp - 105)
        If j = 1 Then lngCaractereControle = strCarTemp
        lngCaractereControle = (lngCaractereControle + (j - 1) * strCarTemp) Mod 103
    Next
 
    'Caractère ASCII de la clé de contrôle
    lngCaractereControle = IIf(lngCaractereControle < 95, lngCaractereControle + 32, lngCaractereControle + 105)
 
    'Ajout du caractère ASCII de la clé de contrôle et du caractère d'arrêt
    Code128 = Code128 & Chr(lngCaractereControle) & Chr(211)
 
    Exit Function
 
GestionErreurs:
 
    'Transmet l'erreur à la procédure appelante
    Err.Raise Err.Number, "Code128"
 
End Function
 
Public Function MotifCodeBarres128(strChaine As String) As String
 
    On Error GoTo GestionErreurs
 
    Select Case Asc(strChaine)
        'Caractère = Espace / Table B = Espace / Table C = 00
        Case 32: MotifCodeBarres128 = "11011001100"
        'Caractère = ! / Table B = ! / Table C = 01
        Case 33: MotifCodeBarres128 = "11001101100"
        'Caractère = " / Table B = " / Table C = 02
        Case 34: MotifCodeBarres128 = "11001100110"
        'Caractère = # / Table B = # / Table C = 03
        Case 35: MotifCodeBarres128 = "10010011000"
        'Caractère = $ / Table B = $ / Table C = 04
        Case 36: MotifCodeBarres128 = "10010001100"
        'Caractère = % / Table B = % / Table C = 05
        Case 37: MotifCodeBarres128 = "10001001100"
 
        'Suite du code...
 
        ' Caractère = Ï - Table B = Fnc 1 / Table C = Fnc 1
        Case 207: MotifCodeBarres128 = "11110101110"
        ' Caractère = Ð - Table B = Start A / Table C = Start A
        Case 208: MotifCodeBarres128 = "11010000100"
        ' Caractère = Ñ - Table B = Start B / Table C = Start B
        Case 209: MotifCodeBarres128 = "11010010000"
        ' Caractère = Ò - Table B = Start C / Table C = Start C
        Case 210: MotifCodeBarres128 = "11010011100"
        ' Caractère = Ó - Table B = Stop / Table C = Stop
        Case 211: MotifCodeBarres128 = "1100011101011"
        'Erreur
        Case Else: Err.Raise 514
    End Select
 
    'Sortie de la fonction
    Exit Function
 
GestionErreurs:
 
    'Transmet l'erreur à la procédure appelante
    Err.Raise Err.Number, "MotifCodeBarres128"
 
End Function
 
 
Public Sub TracerMotifCodeBarres128(Ctrl As Control, rpt As Report)
 
    'Déclaration des variables
    'Chaîne complète des modules du code-barres
    Dim strCodeBarres As String
    'Type d'un module : 1 = barre / 0 = espace
    Dim strTypeModule As String
    'Variable de compteur
    Dim i As Long
    'Largeur de la zone de texte
    Dim sngLargeurZoneTexte As Single
    'Valeur de la marge gauche en twips
    Dim sngMargeGauche As Single
    'Coordonnée horizontale (X1) du point de départ des barres et des espaces
    Dim sngX1 As Single
    'Coordonnée verticale (Y1) du point de départ des barres et des espaces
    Dim sngY1 As Single
    'Coordonnée horizontale (X2) du point d'arrivée des barres et des espaces
    Dim sngX2 As Single
    'Coordonnée verticale (Y2) du point d'arrivée des barres et des espaces
    Dim sngY2 As Single
 
On Error GoTo GestionErreurs
 
'Affectation de la chaîne de caractères du code-barres à la variable
If Not IsNull(Ctrl.Value) Then
    strCodeBarres = Ctrl.Value
Else
    Exit Sub
End If
 
'Initialisation des coordonnées X1, Y1 et X2 en twips
sngX1 = Ctrl.Left
sngY1 = Ctrl.Top
sngX2 = lngTailleModule
 
'Initialisation de la coordonnée Y2
Select Case strHauteurCodeBarres
    'Si le type de hauteur est "Variable"
    Case "Variable"
        'La coordonnée verticale du point d'arrivée est égale à la valeur
        'de la variable lngHauteurModule
        sngY2 = lngHauteurModule
    'Si le type de hauteur est "Fixe"
    Case Else
        'La coordonnée verticale du point d'arrivée est définie par la hauteur
        'de la zone de texte txtCodeBarres
        sngY2 = Ctrl.Height
End Select
 
'Calcul de la valeur de la marge à appliquer à gauche
sngLargeurZoneTexte = Ctrl.Width
sngMargeGauche = Int((sngLargeurZoneTexte - lngLargeurCodeBarres) / 2)
 
'Décalage de la valeur de la coordonnée X1 pour centrer le code-barres
sngX1 = sngX1 + sngMargeGauche
 
'Traçage du code-barres
For i = 1 To Len(strCodeBarres)
    'Type de module, barre ou espace, à tracer
    strTypeModule = Mid(strCodeBarres, i, 1)
    Select Case strTypeModule
        Case "1"
            'Traçage d'une barre
            rpt.Line (sngX1, sngY1)-Step(sngX2, sngY2), CouleurBarre, BF
            'Calcul de la coordonnée X1 suivante
            sngX1 = sngX1 + lngTailleModule
        Case "0"
            'Traçage d'un espace
            rpt.Line (sngX1, sngY1)-Step(sngX2, sngY2), CouleurEspace, BF
            'Calcul de la coordonnée X1 suivante
            sngX1 = sngX1 + lngTailleModule
    End Select
Next i
 
    'Sortie de la procédure
    Exit Sub
 
GestionErreurs:
 
    'Transmet l'erreur à la procédure appelante
    Err.Raise Err.Number, "TracerMotifCodeBarres128"
 
End Sub

Merci de l'aide ;)

Bonjour,

Déjà, si tu copiais la fonction MotifCodeBarres128 au complet, ça devrait mieux fonctionner.

N'as tu pas remarqué qu'elle était tronquée sur le tuto ?

Regardes depuis la ligne 309 du code que tu as posté.

Le code complet de cette fonction, tu dois le télécharger.

Bonjour

J'ai modifié le code et l'ouverture de l'état se fait bien mais sans les codes barre... pfff suis vraiment nul!!! J'ai encore du oublier quelque chose...

Bonsoir,

Oui, il est probable que tu ais omis une étape. Il est possible également qu'il y ait un bug quelconque dans le tuto.

La seule chose qu'il te reste à faire, c'est de faire un debug de ta petite application.

Dans le tuto, j'utilise beaucoup :

Code:

debug.print

et la fenêtre d'exécution.

Il te faut donc contrôler, pas à pas, que tout fonctionne correctement, notamment que les fonctions retournent bien les résultats attendus.

C'est parfois long, pas très gratifiant, mais c'est le plus sûr moyen de parvenir à un résultat.

Bonsoir,

En fait je pense que l'erreur du tuto se trouve à ce niveau :

Code:

Private Sub Detail_Format(cancel As Integer, FormatCount As Integer)

Je suis aussi tombé sur le cas où tout semblait marcher, mais les code-barres ne s'affichaient pas.
Eh ben simplement parce que au lieu de Détail_Format, nous avons Detail_Format.

Si on récupère la base jointe à ce fil, cette erreur a été corrigée
J'espère que ça aidera.

Cordialement,

Merci pour ton intervention.

C'est probablement assez bien vu ;)

Il faut que je reprenne ce problème. Soit en mentionnant de changer le libellé de la fonction, soit celui de la section Détail.

Merci encore.

Et oui c'est encore moi...

Bonjour

Je suis de retour sur cette discussion pour vous poser une petite question : est-il possible d'adapter l'impression des codes barres selon le type de feuille utilisée ?

Je m'explique : dans cette base, les codes barres ne s'imprime que sur 2 colonnes. Je souhaiterai savoir s'il est possible de choisir le nombre de colonnes (les feuilles que je souhaite utiliser possèdent 6 colonnes d'étiquettes) ainsi que le nombre de lignes

Merci de me répondre.

Cordialement ;)

Tazzou,

Dans les configurations de ton état tout simplement (marges, nombre de colonnes..), à moins que tu veuilles le gérer toi même par du code, dans ce cas !

https://msdn.microsoft.com/fr-fr/lib.../ff821394.aspx

et ici une lecture qui s'adapte facilement à un projet access

http://vb.developpez.com/bidou/vb-im...n/?page=emploi

jimbolion

Bonjour,
je suis toujours épaté et ébahi par la qualité de tes tutos et du travail fournit.
Un énorme merci, chez moi cela fonctionne à merveille et cela m'enleve une belle épine du pied !!!

:D:roll:

Pour implémentation Excel

Bonjour Domi !

Merci beaucoup pour ce tutoriel très utile !
Pour implémentation dans Excel, on utilise la fonction AddShape.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Sub TraceCodeBarres(strChaine As String)
 
    'voici les 4 coordonnées nécessaires pour tracer notre module
    Dim LeftX As Single, TopY As Single, Width As Single, Depth As Single
    Dim lngTailleModule As Single
 
    LeftX = 500: TopY = 155: Width = lngTailleModule: Depth = 50
    lngTailleModule = 1
 
    For i = 1 To Len(strChaine)
 
        If Mid(strChaine, i, 1) = "1" Then ActiveSheet.Shapes.AddShape msoShapeRectangle, LeftX, TopY, Width, Depth)
 
        'Calcul de la coordonnée X1 suivante
        LeftX = LeftX + lngTailleModule
 
    Next i
 
End Sub

Davy

Bravo !

Bonjour,

Bonne et heureuse année pour commencer et Vraiment super boulot!

J'aurais en revanche une question concernant le fichier d'origine mis un peu plus haut dans les posts.

Est-il possible de créer plus de 700 codes-barres en une seule fois ? ( 1 feuille/étiquette par code-barre )

Je m'explique, pour mon travail je dois créer des étiquettes SSCC contenant un code-barre EAN128, mais je dois en créer aux alentours des 700 par jour.
J'aimerai que les chiffres qui alimentent txtChaineCaracteres proviennent directement d'une autre table (requête)

Merci de ton retour

codes-barres UPCA

Bonjour,

La création de code-barres 128 en VBA fonctionne très bien, d'ailleurs je l'utilise et tout est numéro 1. Très bon travail et très bon tuto.
Maintenant, je cherche comment créer du code-barres UPCA qui est surtout utilisé dans le domaine alimentaire.
Si quelqu'un a des pistes de solution, ce serait très apprécié de les partager.

Merci encore pour tout le travail accompli.

P.S. Je suis sous Access 2016 et le code 128 fonctionne sans problème.

Jean

bien

Salut, voir également ici

codes-barres UPC A

Citation:

Envoyé par kiki29

Salut, voir également ici

Merci, c'est très apprécié. Je te reviens avec plus de commentaires.

Merci beaucoup pour ce tuto.

Erreur 3265

Bonjour, merci pour ce tuto, mais j'ai un petit problème lors de la réalisation du projet, une message s'affiche lorsqu'on clique sur le bouton aperçu:
Source: DAO.fields
Erreur n°: 3265

Est-ce que vous pouvez m'aider à résoudre ce problème?
Merci.

Comment lire mes codes?

Bonjour tout le monde
Vous l'aurez remarqué, j'ai 5 ans de retard sur le début de la discution; mais cela démontre à suffisance l’intérêt et la qualité du travail de Domi2.
J'ai intégré les modules de Domi2 à une application scolaire sous Access et j'obtiens bien les codes-barres, mais quand je veux les lire avec une douchette modèle "TT-BS014" que j'ai acquise sur Amazone, j'obtiens des réponses du type "ééé" ou "&:!(M_)" au lieu de simples numéros que j'ai attribués au élèves. Pouvez-vous me dire si le lecteur peux être le problème et quel lecteur choisir.
Ps: j’édite les codes sur une colonne.
Merci

Bonjour,

Tout d'abord, merci beaucoup pour ce tutoriel.

J'ai essayé de le reproduire mais ça ne fonctionne pas.

Je suis débutante sur Access et en Vba.

Les sub des boutons ne s'exécutent pas mais je n'ai pas de message d'erreur.

Savez-vous d'où pourrait venir ce problème ?

Merci d'avance

Bonjour.
As-tu attribué les sub à chaque bouton ???
Dans les propriétés du bouton onglet Événement ligne au clic As-tu sélectionné procédure événementielle ???