Prüfzeichen für HIBC UDI Code berechnen

Modul_HIBC_UDI.bas

' VBA Modul für Microsoft Excel "Modul_HIBC_UDI"
' HIBC - UDI Code
' -------------------------------------------------------------------------------------

Option Explicit


' Zeichenvorrat des HIBC UDI Codes.
' Index-1 in diesem String ist der Wert des Zeichen für die Prüfsummenberechnung.
' Zeichen '0' = Wert 0, Zeichen '1' = Wert 1, ...
Const HIBC_UDI_CHAR_SET As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%"


' Globales Array als Cache für die HIBC Values.
' Wird nur Funktion Generate_HIBC_UDI_Values verwendet.
Dim HIBC_UDI_Values() As Integer


' Prüft ob ein Array leer ist, z.B. noch nicht dimensioniert ist.
Private Function Is_Array_Empty(arr As Variant) As Boolean
    On Error Resume Next
    Is_Array_Empty = True
    ' Die funktionen UBound , LBound lösen einen Fehler aus, wenn arr nicht dimensioniert sind.
    ' Indiesem Fall, zusammen mit "Resume Next", bleibt der Funktionswert auf True.
    Is_Array_Empty = UBound(arr) < LBound(arr)
End Function


' Funktion zur Generierung des Arrays für ASCII-Wert -> Wert für Prüfsummenberechnung
' Rückgabe: Array von Werten für die Prüfsummenberechnung des HIBC UDI Codes,
'           Index ist der ASC Wert des Zeichens im HIBC UDI Code.
Private Function Generate_HIBC_UDI_Values() As Integer()
    If Is_Array_Empty(HIBC_UDI_Values) Then
        ReDim HIBC_UDI_Values(256)
        Dim ascValue As Integer
        For ascValue = Asc(" ") To 255
            ' Wert des Zeichen für die Prüfsumme ermitteln aus HIBC_UDI_CHAR_SET
            Dim charValue As String
            ' Der HIBC Code sollte keine Kleinbuchstaben enthalten.
            ' Dennoch werden Kleinbuchstaben wie Großbuchstaben in die Prüfsumme aufgenommen.
            charValue = UCase(Chr(ascValue))
            ' Alle Zeichen, die nicht im HIBC Code auftreten dürfen bekommen den Wert 0.
            ' Damit werden diese Zeichen bei der Prüfziffernberechnung ignoriert.
            HIBC_UDI_Values(ascValue) = InStr(HIBC_UDI_CHAR_SET, charValue) - 1
        Next ascValue
    End If
    Generate_HIBC_UDI_Values = HIBC_UDI_Values
End Function


' Prüfzeichen für HIBC UDI Code berechnen.
' Eingabe: Der HIBC Code ohne das Prüfzeichen.
' Rückgabe: Das Prüfzeichen für den HIBC.
' Enthält der Code nicht erlaubte Zeichen, werden diese in der Prüfsumme ignoriert.
'
' Quelle des urspünglichen Code für das VBA-Makro:
' https://www.activebarcode.de/codes/checkdigit/modulo43
' Eine Spezifikation des HIBC UDI "ANSI/HIBC 2.6 - 2016":
' https://www.hibcc.org/wp-content/uploads/ANS_HIBC_SLS_2.6_2016.pdf
Public Function HIBC_Pruefziffern(code As String) As String
    ' Map ASC-Wert -> Wert in Prüfsumme holen
    Dim value() As Integer
    value = Generate_HIBC_UDI_Values()
    ' Prüfsumme akkumulieren
    Dim accu As Integer
    accu = 0
    Dim index As Integer
    For index = 1 To Len(code)
        ' Summiert wird sofort modula 43, damit kein Überlauf auftreten kann.
        accu = (accu + value(Asc(Mid(code, index, 1)))) Mod 43
    Next index
    ' Prüfzeichenzeichen hat Index=Summe+1, weil Zeichen auf Index 1 den Wert 0 hat.
    HIBC_Pruefziffern = Mid$(HIBC_UDI_CHAR_SET, accu + 1, 1)
End Function


' Kontrolle der HIBC_Pruefziffern Funktion mit bekannten Werten
Private Sub Test_HIBC_Pruefziffern()
    Debug.Assert HIBC_Pruefziffern("+A99912345/$$52001510X3/16D20111212/S77DEFG45") = "7"
    Debug.Assert HIBC_Pruefziffern("+A99912345/$10X3/16D20111231/14D20200131") = "3"
    Debug.Assert HIBC_Pruefziffern("+A99912349/$10X3/16D20111231/14D20200131/Q500") = "Z"
    Debug.Assert HIBC_Pruefziffern("+EDD153654312250/$16008051/16D20200214/14D20350201") = "G"
End Sub