Créer des codes barres rapidement

Tibo62

XLDnaute Occasionnel
Bonjour à tous,

Je suis en plein développement d'un logiciel et malheureusement je bloque un peu, j'aimerais créer des codes barres de manière automatique, parce que la je dois les créer un par un à l'aide d'une macro qui convertit les : 15697852179662 en code barre cependant il y a 8961 lignes et certainement bien plus dans les mois à venir donc si quelqu'un pouvait m'aider ce serait vraiment sympathique de sa part.
Je vous met un fichier exemple ne vous en faites pas si lorsque vous l'ouvrez cela ressemble à des hiéroglyphes et pas à un code barres c'est parce que j'ai du supprimer la macro qui ouvre le fichier code128.ttf mais chez moi cela fonctionnera. Par contre le texte afficher dans la cellule est le bon.
Merci d'avance pour tout aide.
Cordialement
Thibaut
 

Pièces jointes

  • test excel download.xlsx
    265.1 KB · Affichages: 35
  • test excel download.xlsx
    265.1 KB · Affichages: 53
  • test excel download.xlsx
    265.1 KB · Affichages: 47

Tibo62

XLDnaute Occasionnel
Re : Créer des codes barres rapidement

Bonjour Modeste Geedee, je veux créer des codes barres de manière automatique, j'en ai créer 300 a peu près a la main pour pouvoir démarrer.
Maintenant je souhaiterais créer une macro qui aille sur la ligne 301, crée un code barres avec des chiffres totalement aléatoires, ensuite qu'elle passe à la ligne 302 et ainsi de suite.

Merci de me consacrer du temps.
Cordialement
Thibaut
 

Modeste geedee

XLDnaute Barbatruc
Re : Créer des codes barres rapidement

Bonsour®
:mad:
:rolleyes:

VB:
Sub Creer_CB128()
Dim ligne As Long
ligne = 2
While Not IsEmpty(Cells(ligne, 1))
Cells(ligne, 4) = lamacroquivabien(Cells(ligne, 5))
ligne = ligne + 1
Wend
End Sub
VB:
Function lamacroquivabien(chaine$)
' ici le code de la macro qui va bien mais que tu as effacé par discrétion
' mais chez moi cela fonctionne
'  ;o)))
'---------->>>>>>>>>>>>lamacroquivabien = Code128$(chaine$)
End Function
Capture.jpg
 

Pièces jointes

  • Capture.jpg
    Capture.jpg
    63.9 KB · Affichages: 31
  • Capture.jpg
    Capture.jpg
    63.9 KB · Affichages: 39

Tibo62

XLDnaute Occasionnel
Re : Créer des codes barres rapidement

Merci modeste geedee, cependant j'ai encore une petite question parce que dans ma macro d'origine j'utilisais les chiffres que j'entrais dans TextBox13 cependant aujourd'hui je souhaite que ces chiffres soit créer de manière automatique as tu une idée? merci d'avance je te met le code que j'utilise :


Function lamacroquivabien()
Call vérif_cbval
Dim CodeBarre$
CodeBarre$ = code128$(Cells(ligne, 5))
End Function


Sub Creer_CB128()
Dim ligne As Long
ligne = 2
While Not IsEmpty(Cells(ligne, 1))
Cells(ligne, 4) = lamacroquivabien
ligne = ligne + 1
Wend
End Sub


Sub vérif_cbval()

Dim code_val As Boolean
code_val = False

Select Case ActiveCell.Value
Case "ÒE -Í7jÓ"
code_val = True ' 1
Case "ÒE 7Í7?Ó"
code_val = True ' 2
Case "ÒE AÍ7{Ó"
code_val = True ' 3
Case "ÒE KÍ7PÓ"
code_val = True ' 4
Case "ÒE UÍ7%Ó"
code_val = True ' 5
Case "ÒE _Í7aÓ"
code_val = True ' 6
Case "ÒE iÍ76Ó"
code_val = True ' 7
Case "ÒE sÍ7rÓ"
code_val = True ' 8
Case "ÒE }Í7GÓ"
code_val = True ' 9
Case "ÒE !#Í73Ó"
code_val = True ' 10
Case "ÒE " & Chr(34) & "#Í78Ó"
code_val = True ' 20
Case "ÒE ##Í7=Ó"
code_val = True ' 30
Case "ÒE $#Í7BÓ"
code_val = True ' 40
Case "ÒE %#Í7GÓ"
code_val = True ' 50
Case "ÒE &#Í7LÓ"
code_val = True ' 60
Case "ÒE '#Í7QÓ"
code_val = True ' 70
Case "ÒE (#Í7VÓ"
code_val = True ' 80
Case "ÒE )#Í7[Ó"
code_val = True ' 90
Case "ÒE *#Í7`Ó"
code_val = True ' 100
Case "ÒE 4#Í7+Ó"
code_val = True ' 200
Case "ÒE >#Í7]Ó"
code_val = True ' 300
Case "ÒE H#Í7(Ó"
code_val = True ' 400
Case "ÒE R#Í7ZÓ"
code_val = True ' 500
Case "ÒE \#Í7%Ó"
code_val = True ' 600
Case "ÒE f#Í7WÓ"
code_val = True ' 700
Case "ÒE p#Í7" & Chr(34) & "Ó"
code_val = True ' 800
Case "ÒE z#Í7TÓ"
code_val = True ' 900
Case "ÒE ! #Í72Ó"
code_val = True ' 1000
Case "ÒE & Chr(34) & #Í76Ó"
code_val = True ' 2000
Case "ÒE # #Í7:Ó"
code_val = True ' 3000
Case "ÒE $ #Í7>Ó"
code_val = True ' 4000
Case "ÒE % #Í7BÓ"
code_val = True ' 5000
Case "ÒE & #Í7FÓ"
code_val = True ' 6000
Case "ÒE ' #Í7JÓ"
code_val = True ' 7000
Case "ÒE ( #Í7NÓ"
code_val = True ' 8000
Case "ÒE ) #Í7RÓ"
code_val = True ' 9000
Case "ÒE * #Í7VÓ"
code_val = True ' 10000
Case "ÒE 4 #Í7~Ó"
code_val = True ' 20000
Case "ÒE > #Í7?Ó"
code_val = True ' 30000
Case "ÒE H #Í7gÓ"
code_val = True ' 40000
Case "ÒE R #Í7(Ó"
code_val = True ' 50000
Case "ÒE \ #Í7PÓ"
code_val = True ' 60000
Case "ÒE f #Í7xÓ"
code_val = True ' 70000
Case "ÒE p #Í79Ó"
code_val = True ' 80000
Case "ÒE z #Í7aÓ"
code_val = True ' 90000
Case "ÒE ! #Í71Ó"
code_val = True ' 100000
Case "ÒE & Chr(34) & #Í74Ó"
code_val = True ' 200000
Case "ÒE # #Í77Ó"
code_val = True ' 300000
Case "ÒE $ #Í7:Ó"
code_val = True ' 400000
Case "ÒE % #Í7=Ó"
code_val = True ' 500000
Case "ÒE & #Í7@Ó"
code_val = True ' 600000
Case "ÒE ' #Í7CÓ"
code_val = True ' 700000
Case "ÒE ( #Í7FÓ"
code_val = True ' 800000
Case "ÒE ) #Í7IÓ"
code_val = True ' 900000
End Select

code_val_tot = code_val_tot + code_val


End Sub
 
Dernière édition:

Tibo62

XLDnaute Occasionnel
Re : Créer des codes barres rapidement

Je te met tout mon code Modeste Geedee comme ça dit moi si tu vois des améliorations :

Code:
Const entrees_decimales_permises = ".,0123456789" & vbCr & vbBack
Const Point = "."
Const Virgule = ","
Dim combo As String
Dim clavier As String
Dim comd4 As String
Dim pass As Boolean
Dim recherche_combo_1 As Boolean
Dim recherche_combo_2 As Boolean

Private CodeClair$, CodeBarre$

#If Win64 Then
Private Declare PtrSafe Function ShellExecute Lib "SHELL32.DLL" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
Private Declare PtrSafe Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As LongPtr
#Else
Private Declare Function ShellExecute Lib "SHELL32.DLL" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
#End If

Code:
Function lamacroquivabie ()
 Call vérif_cbval
 Dim CodeBarre$
CodeBarre$ = code128$(Me.TextBox13.Text)
 End Function


Code:
Sub Creer_CB128()
 Dim ligne As Long
 ligne = 2
 While Not IsEmpty(Cells(ligne, 1))
 Cells(ligne, 4) = lamacroquivabien
 ligne = ligne + 1
 Wend
 End Sub

Code:
Sub vérif_cbval()

 Dim code_val As Boolean
 code_val = False

 Select Case ActiveCell.Value
 Case "ÒE -Í7jÓ"
 code_val = True ' 1
 Case "ÒE 7Í7?Ó"
 code_val = True ' 2
 Case "ÒE AÍ7{Ó"
 code_val = True ' 3
 Case "ÒE KÍ7PÓ"
 code_val = True ' 4
 Case "ÒE UÍ7%Ó"
 code_val = True ' 5
 Case "ÒE _Í7aÓ"
 code_val = True ' 6
 Case "ÒE iÍ76Ó"
 code_val = True ' 7
 Case "ÒE sÍ7rÓ"
 code_val = True ' 8
 Case "ÒE }Í7GÓ"
 code_val = True ' 9
 Case "ÒE !#Í73Ó"
 code_val = True ' 10
 Case "ÒE " & Chr(34) & "#Í78Ó"
 code_val = True ' 20
 Case "ÒE ##Í7=Ó"
 code_val = True ' 30
 Case "ÒE $#Í7BÓ"
 code_val = True ' 40
 Case "ÒE %#Í7GÓ"
 code_val = True ' 50
 Case "ÒE &#Í7LÓ"
 code_val = True ' 60
 Case "ÒE '#Í7QÓ"
 code_val = True ' 70
 Case "ÒE (#Í7VÓ"
 code_val = True ' 80
 Case "ÒE )#Í7[Ó"
 code_val = True ' 90
 Case "ÒE *#Í7`Ó"
 code_val = True ' 100
 Case "ÒE 4#Í7+Ó"
 code_val = True ' 200
 Case "ÒE >#Í7]Ó"
 code_val = True ' 300
 Case "ÒE H#Í7(Ó"
 code_val = True ' 400
 Case "ÒE R#Í7ZÓ"
 code_val = True ' 500
 Case "ÒE \#Í7%Ó"
 code_val = True ' 600
 Case "ÒE f#Í7WÓ"
 code_val = True ' 700
 Case "ÒE p#Í7" & Chr(34) & "Ó"
 code_val = True ' 800
 Case "ÒE z#Í7TÓ"
 code_val = True ' 900
 Case "ÒE ! #Í72Ó"
 code_val = True ' 1000
 Case "ÒE & Chr(34) & #Í76Ó"
 code_val = True ' 2000
 Case "ÒE # #Í7:Ó"
 code_val = True ' 3000
 Case "ÒE $ #Í7>Ó"
 code_val = True ' 4000
 Case "ÒE % #Í7BÓ"
 code_val = True ' 5000
 Case "ÒE & #Í7FÓ"
 code_val = True ' 6000
 Case "ÒE ' #Í7JÓ"
 code_val = True ' 7000
 Case "ÒE ( #Í7NÓ"
 code_val = True ' 8000
 Case "ÒE ) #Í7RÓ"
 code_val = True ' 9000
 Case "ÒE * #Í7VÓ"
 code_val = True ' 10000
 Case "ÒE 4 #Í7~Ó"
 code_val = True ' 20000
 Case "ÒE > #Í7?Ó"
 code_val = True ' 30000
 Case "ÒE H #Í7gÓ"
 code_val = True ' 40000
 Case "ÒE R #Í7(Ó"
 code_val = True ' 50000
 Case "ÒE \ #Í7PÓ"
 code_val = True ' 60000
 Case "ÒE f #Í7xÓ"
 code_val = True ' 70000
 Case "ÒE p #Í79Ó"
 code_val = True ' 80000
 Case "ÒE z #Í7aÓ"
 code_val = True ' 90000
 Case "ÒE ! #Í71Ó"
 code_val = True ' 100000
 Case "ÒE & Chr(34) & #Í74Ó"
 code_val = True ' 200000
 Case "ÒE # #Í77Ó"
 code_val = True ' 300000
 Case "ÒE $ #Í7:Ó"
 code_val = True ' 400000
 Case "ÒE % #Í7=Ó"
 code_val = True ' 500000
 Case "ÒE & #Í7@Ó"
 code_val = True ' 600000
 Case "ÒE ' #Í7CÓ"
 code_val = True ' 700000
 Case "ÒE ( #Í7FÓ"
 code_val = True ' 800000
 Case "ÒE ) #Í7IÓ"
 code_val = True ' 900000
 End Select

 code_val_tot = code_val_tot + code_val


 End Sub

Code:
Public Function code128$(chaine$)

On Error Resume Next

  Dim i%, checksum&, mini%, dummy%, tableB As Boolean
  code128$ = ""
  If Len(chaine$) > 0 Then
    For i% = 1 To Len(chaine$)
      Select Case Asc(Mid$(chaine$, i%, 1))
      Case 32 To 126, 203
      Case Else
        i% = 0
        Exit For
      End Select
    Next
    code128$ = ""
    tableB = True
    If i% > 0 Then
      i% = 1
      Do While i% <= Len(chaine$)
        If tableB Then
          mini% = IIf(i% = 1 Or i% + 3 = Len(chaine$), 4, 6)
          GoSub testnum
          If mini% < 0 Then
            If i% = 1 Then
              code128$ = Chr$(210)
            Else
              code128$ = code128$ & Chr$(204)
            End If
            tableB = False
          Else
            If i% = 1 Then code128$ = Chr$(209)
          End If
        End If
        If Not tableB Then
          mini% = 2
          GoSub testnum
          If mini% < 0 Then
            dummy% = Val(Mid$(chaine$, i%, 2))
            dummy% = IIf(dummy% < 95, dummy% + 32, dummy% + 105)
            code128$ = code128$ & Chr$(dummy%)
            i% = i% + 2
          Else
            code128$ = code128$ & Chr$(205)
            tableB = True
          End If
        End If
        If tableB Then
          code128$ = code128$ & Mid$(chaine$, i%, 1)
          i% = i% + 1
        End If
      Loop
      For i% = 1 To Len(code128$)
        dummy% = Asc(Mid$(code128$, i%, 1))
        dummy% = IIf(dummy% < 127, dummy% - 32, dummy% - 105)
        If i% = 1 Then checksum& = dummy%
        checksum& = (checksum& + (i% - 1) * dummy%) Mod 103
      Next
      checksum& = IIf(checksum& < 95, checksum& + 32, checksum& + 105)
      code128$ = code128$ & Chr$(checksum&) & Chr$(211)
    End If
  End If
  Exit Function
testnum:
  mini% = mini% - 1
  If i% + mini% <= Len(chaine$) Then
    Do While mini% >= 0
      If Asc(Mid$(chaine$, i% + mini%, 1)) < 48 Or Asc(Mid$(chaine$, i% + mini%, 1)) > 57 Then Exit Do
      mini% = mini% - 1
    Loop
  End If
Return
End Function
 

Tibo62

XLDnaute Occasionnel
Re : Créer des codes barres rapidement

Bonjour le forum ayant trouvé la solution je la propose pour ceux que sa intéresse ou que sa intéressera plus tard :

Code:
 Sub Creer_CB128()
 Dim ligne As Long
 ligne = 2
 Dim CodeBarre$
 While Not IsEmpty(Cells(ligne, 1))
 Cells(ligne, 5).Select
 Call vérif_cbval
 CodeBarre$ = code128$(Cells(ligne, 5))
 Cells(ligne, 4) = CodeBarre$
 ligne = ligne + 1
 Wend
 End Sub

Code:
 Sub vérif_cbval()

 Dim code_val As Boolean
 code_val = False

 Select Case ActiveCell.Value
 Case "ÒE -Í7jÓ"
 code_val = True ' 1
 Case "ÒE 7Í7?Ó"
 code_val = True ' 2
 Case "ÒE AÍ7{Ó"
 code_val = True ' 3
 Case "ÒE KÍ7PÓ"
 code_val = True ' 4
 Case "ÒE UÍ7%Ó"
 code_val = True ' 5
 Case "ÒE _Í7aÓ"
 code_val = True ' 6
 Case "ÒE iÍ76Ó"
 code_val = True ' 7
 Case "ÒE sÍ7rÓ"
 code_val = True ' 8
 Case "ÒE }Í7GÓ"
 code_val = True ' 9
 Case "ÒE !#Í73Ó"
 code_val = True ' 10
 Case "ÒE " & Chr(34) & "#Í78Ó"
 code_val = True ' 20
 Case "ÒE ##Í7=Ó"
 code_val = True ' 30
 Case "ÒE $#Í7BÓ"
 code_val = True ' 40
 Case "ÒE %#Í7GÓ"
 code_val = True ' 50
 Case "ÒE &#Í7LÓ"
 code_val = True ' 60
 Case "ÒE '#Í7QÓ"
 code_val = True ' 70
 Case "ÒE (#Í7VÓ"
 code_val = True ' 80
 Case "ÒE )#Í7[Ó"
 code_val = True ' 90
 Case "ÒE *#Í7`Ó"
 code_val = True ' 100
 Case "ÒE 4#Í7+Ó"
 code_val = True ' 200
 Case "ÒE >#Í7]Ó"
 code_val = True ' 300
 Case "ÒE H#Í7(Ó"
 code_val = True ' 400
 Case "ÒE R#Í7ZÓ"
 code_val = True ' 500
 Case "ÒE \#Í7%Ó"
 code_val = True ' 600
 Case "ÒE f#Í7WÓ"
 code_val = True ' 700
 Case "ÒE p#Í7" & Chr(34) & "Ó"
 code_val = True ' 800
 Case "ÒE z#Í7TÓ"
 code_val = True ' 900
 Case "ÒE ! #Í72Ó"
 code_val = True ' 1000
 Case "ÒE & Chr(34) & #Í76Ó"
 code_val = True ' 2000
 Case "ÒE # #Í7:Ó"
 code_val = True ' 3000
 Case "ÒE $ #Í7>Ó"
 code_val = True ' 4000
 Case "ÒE % #Í7BÓ"
 code_val = True ' 5000
 Case "ÒE & #Í7FÓ"
 code_val = True ' 6000
 Case "ÒE ' #Í7JÓ"
 code_val = True ' 7000
 Case "ÒE ( #Í7NÓ"
 code_val = True ' 8000
 Case "ÒE ) #Í7RÓ"
 code_val = True ' 9000
 Case "ÒE * #Í7VÓ"
 code_val = True ' 10000
 Case "ÒE 4 #Í7~Ó"
 code_val = True ' 20000
 Case "ÒE > #Í7?Ó"
 code_val = True ' 30000
 Case "ÒE H #Í7gÓ"
 code_val = True ' 40000
 Case "ÒE R #Í7(Ó"
 code_val = True ' 50000
 Case "ÒE \ #Í7PÓ"
 code_val = True ' 60000
 Case "ÒE f #Í7xÓ"
 code_val = True ' 70000
 Case "ÒE p #Í79Ó"
 code_val = True ' 80000
 Case "ÒE z #Í7aÓ"
 code_val = True ' 90000
 Case "ÒE ! #Í71Ó"
 code_val = True ' 100000
 Case "ÒE & Chr(34) & #Í74Ó"
 code_val = True ' 200000
 Case "ÒE # #Í77Ó"
 code_val = True ' 300000
 Case "ÒE $ #Í7:Ó"
 code_val = True ' 400000
 Case "ÒE % #Í7=Ó"
 code_val = True ' 500000
 Case "ÒE & #Í7@Ó"
 code_val = True ' 600000
 Case "ÒE ' #Í7CÓ"
 code_val = True ' 700000
 Case "ÒE ( #Í7FÓ"
 code_val = True ' 800000
 Case "ÒE ) #Í7IÓ"
 code_val = True ' 900000
 End Select

 code_val_tot = code_val_tot + code_val


 End Sub


Code:
Public Function code128$(chaine$)

On Error Resume Next

  Dim i%, checksum&, mini%, dummy%, tableB As Boolean
  code128$ = ""
  If Len(chaine$) > 0 Then
    For i% = 1 To Len(chaine$)
      Select Case Asc(Mid$(chaine$, i%, 1))
      Case 32 To 126, 203
      Case Else
        i% = 0
        Exit For
      End Select
    Next
    code128$ = ""
    tableB = True
    If i% > 0 Then
      i% = 1
      Do While i% <= Len(chaine$)
        If tableB Then
          mini% = IIf(i% = 1 Or i% + 3 = Len(chaine$), 4, 6)
          GoSub testnum
          If mini% < 0 Then
            If i% = 1 Then
              code128$ = Chr$(210)
            Else
              code128$ = code128$ & Chr$(204)
            End If
            tableB = False
          Else
            If i% = 1 Then code128$ = Chr$(209)
          End If
        End If
        If Not tableB Then
          mini% = 2
          GoSub testnum
          If mini% < 0 Then
            dummy% = Val(Mid$(chaine$, i%, 2))
            dummy% = IIf(dummy% < 95, dummy% + 32, dummy% + 105)
            code128$ = code128$ & Chr$(dummy%)
            i% = i% + 2
          Else
            code128$ = code128$ & Chr$(205)
            tableB = True
          End If
        End If
        If tableB Then
          code128$ = code128$ & Mid$(chaine$, i%, 1)
          i% = i% + 1
        End If
      Loop
      For i% = 1 To Len(code128$)
        dummy% = Asc(Mid$(code128$, i%, 1))
        dummy% = IIf(dummy% < 127, dummy% - 32, dummy% - 105)
        If i% = 1 Then checksum& = dummy%
        checksum& = (checksum& + (i% - 1) * dummy%) Mod 103
      Next
      checksum& = IIf(checksum& < 95, checksum& + 32, checksum& + 105)
      code128$ = code128$ & Chr$(checksum&) & Chr$(211)
    End If
  End If
  Exit Function
testnum:
  mini% = mini% - 1
  If i% + mini% <= Len(chaine$) Then
    Do While mini% >= 0
      If Asc(Mid$(chaine$, i% + mini%, 1)) < 48 Or Asc(Mid$(chaine$, i% + mini%, 1)) > 57 Then Exit Do
      mini% = mini% - 1
    Loop
  End If
Return
End Function
 

Discussions similaires

Statistiques des forums

Discussions
312 489
Messages
2 088 855
Membres
103 979
dernier inscrit
bderradji