Microsoft 365 Formule pour code barre à critères multiples

Dudu2 à dit:

Bonjour,
Voici un code dont je me suis servi pour générer des codes barre.
Il n'y a pas de formule pour générer un code barre. Il faut faire du VBA.
Et pour l'utiliser dans une cellule, en faire une fonction personnalisée.

VB:

Option Explicit

'https://code.adonline.id.au/easily-generate-code-128-barcodes-in-excel/

Public Function CodeBarreEAN128(SourceString As String) As String
    'Written by Philip Treacy, Feb 2014
    'http://www.myonlinetraininghub.com/create-barcodes-with-excel-vba
    'This code is not guaranteed to be error free.  No warranty is implied or expressed. Use at your own risk and carry out your own testing
    'This function is governed by the GNU Lesser General Public License (GNU LGPL) Ver 3
    'Input Parameters : A string
    'Return : 1. An encoded string which produces a bar code when dispayed using the CODE128.TTF font
    '         2. An empty string if the input parameter contains invalid characters
    Dim Counter As Integer
    Dim CheckSum As Long
    Dim Mini As Integer
    Dim Dummy As Integer
    Dim UseTableB As Boolean
    Dim Code128_Barcode As String
   
    If Len(SourceString) = 0 Then Exit Function
   
    'Check for valid characters
    For Counter = 1 To Len(SourceString)
        Select Case Asc(Mid(SourceString, Counter, 1))
            Case 32 To 126, 203
            Case Else
                MsgBox "Invalid character in barcode string." & vbCrLf & vbCrLf & "Please only use standard ASCII characters", vbCritical
                Exit Function
        End Select
    Next
   
    Code128_Barcode = ""
    UseTableB = True
    Counter = 1
   
    Do While Counter <= Len(SourceString)
        If UseTableB Then
            'Check if we can switch to Table C
            Mini = IIf(Counter = 1 Or Counter + 3 = Len(SourceString), 4, 6)
            GoSub Testnum
           
            If Mini < 0 Then 'Use Table C
                If Counter = 1 Then
                    Code128_Barcode = Chr(205)
                Else 'Switch to table C
                    Code128_Barcode = Code128_Barcode & Chr(199)
                End If
                UseTableB = False
            Else
                If Counter = 1 Then Code128_Barcode = Chr(204) 'Starting with table B
            End If
        End If
       
        If Not UseTableB Then
            'We are using Table C, try to process 2 digits
            Mini = 2
            GoSub Testnum
           
            If Mini < 0 Then 'OK for 2 digits, process it
                Dummy = Val(Mid(SourceString, Counter, 2))
                Dummy = IIf(Dummy < 95, Dummy + 32, Dummy + 100)
                Code128_Barcode = Code128_Barcode & Chr(Dummy)
                Counter = Counter + 2
            Else 'We haven't got 2 digits, switch to Table B
                Code128_Barcode = Code128_Barcode & Chr(200)
                UseTableB = True
            End If
        End If
       
        If UseTableB Then
            'Process 1 digit with table B
            Code128_Barcode = Code128_Barcode & Mid(SourceString, Counter, 1)
            Counter = Counter + 1
        End If
    Loop
   
    'Calculation of the checksum
    For Counter = 1 To Len(Code128_Barcode)
        Dummy = Asc(Mid(Code128_Barcode, Counter, 1))
        Dummy = IIf(Dummy < 127, Dummy - 32, Dummy - 100)
        If Counter = 1 Then CheckSum = Dummy
        CheckSum = (CheckSum + (Counter - 1) * Dummy) Mod 103
    Next
   
    'Calculation of the checksum ASCII code
    CheckSum = IIf(CheckSum < 95, CheckSum + 32, CheckSum + 100)
   
    'Add the checksum and the STOP
    Code128_Barcode = Code128_Barcode & Chr(CheckSum) & Chr$(206)
   
    'Return value
    CodeBarreEAN128 = Code128_Barcode
    Exit Function
   
Testnum:
        'if the Mini characters from Counter are numeric, then Mini=0
        Mini = Mini - 1
        If Counter + Mini <= Len(SourceString) Then
            Do While Mini >= 0
                If Asc(Mid(SourceString, Counter + Mini, 1)) < 48 Or Asc(Mid(SourceString, Counter + Mini, 1)) > 57 Then Exit Do
                Mini = Mini - 1
            Loop
        End If
        Return
End Function

Cliquez pour agrandir...