vb@rchiv · Tipps & Tricks · Prüfziffer einer Fahrzeug-Identifizierungsnummer (FIN) ermitteln

Rubrik: Variablen/Strings · Algorithmen/Mathematik | VB-Versionen: VB6

08.10.12

Prüfziffer einer Fahrzeug-Identifizierungsnummer (FIN) ermitteln Funktionen zur Ermittlung der Prüfziffer einer Fahrzeug-Ident-Nr. nach dem EU- und US-Verfahren.
Autor: Richard Mittelstädt	Bewertung:	Views: 19.599
ohne Homepage	System: WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Anbei sind 2 Funktionen:

eine für europäische FINs und
eine für US-VINs

Man kann damit zB. in einer Werkstatt bei der Fahrzeugannahme

Fehleingaben der FIN/VIN vermeiden bzw.
evtl. auch eine schlecht gefälschte FIN/VIN erkennen.

Bei einer EU-FIN muss die errechnete Prüfziffer mit der im Fahrzeugschein rechts neben der FIN stehenden Prüfziffer übereinstimmen. Bei einer US-VIN muss die errechnete Prüfziffer mit dem Zeichen an Pos.9 der VIN übereinstimmen.

Ich habe mir einige Mühe gegeben, dennoch keine Garantie...
Der Code wurde bislang nur wenig getestet.
Ich komme nicht mit sovielen KFZs zusammen...

Hier der Code incl. einer Testfunktion.
Im Code stehen Quellen und Erläuterungen. en Code einfach in ein neues Modul kopieren, es sind keine zusätzlichen Verweise (bei einer ACCESS-Bank) erforderlich.

Europäische FIN
Quelle: anlage_2_Berechnung_Pruefziffer_FIN_Modulo_11_Verfahren_pdf.pdf

Public Function PruefZifferVonFIN(sFIN, Optional ErrTXT As String = "") As String
  ' Berechnung der Prüfziffer zur FIN nach dem Modulo-11-Verfahren:
 
  ' sFIN darf keine Klein-Buchstaben haben
  ' ErrTXT Rückgabe Fehlertext/ erstes nicht erlaubtes Zeichen
 
  ' Die Berechnung ist nur für FIN(EU) nach ISO 3779 !!!
  ' Bei amerikanischer VIN steht die Prüfziffer IMMER auf Pos.9 von links.
  ' Es gelten dabei andere Wichtungen bei den Produktbildungen für die einzelnen Positionen !!!
 
  On Error GoTo ErrHandler:
 
  Dim i As Integer, n  As Integer
  Dim Ch As String * 1
  Dim t1 As String
  Dim PR_FLD(90)
  Dim PrSUMME As Long
 
  ' 2011-09-30 Abblocken wenn leere Bank  vbObject=9
  If VarType(sFIN) = vbObject Then Exit Function
  If Len("" & sFIN) = 0 Then Exit Function
 
  If Len(sFIN) > 17 Then
    PruefZifferVonFIN = "?"
    ErrTXT = "Falsche Länge: " & Len(sFIN) & vbNewLine & _
      "Soll-Länge: max. 17"
    Exit Function
  End If
 
  ' ---- Uebersetzungen für Ziffern -----------
  For i = 48 To 57
    PR_FLD(i) = Chr(i)
  Next i
  ' ---- Uebersetzungen für A...Z -------------
  For i = 65 To 90
    If Chr(i) = "A" Or Chr(i) = "J" Then  ' Neu Anfangen mit 1
      n = 1
    ElseIf Chr(i) = "S" Then              ' Neu Anfangen mit 2 !
      n = 2
    End If
    If Chr(i) = "O" Then                  ' Ausnahme Buchst. O -> 0 (Ziffer Null)
      PR_FLD(i) = 0
    Else
      PR_FLD(i) = n
    End If
    n = n + 1
  Next i
 
  ' ---- Folge in Zifferncode-Folge uebersetzen ------------------
  t1 = ""
  For i = 1 To Len(sFIN)
    Ch = Mid(sFIN, i, 1)
    Select Case Ch
      Case "Ä"        ' Ä, Ö, Ü wie A, Null, U
        Ch = "A"
      Case "Ö"
        Ch = 0
      Case "Ü"
        Ch = "U"
    End Select
    Select Case Asc(Ch)
      Case 48 To 57
        ' OK Ziffern 0...9
      Case 65 To 90
        ' OK Gross-Buchstaben A...Z
      Case Else
        ' Fehler, nicht erlaubtes Zeichen
        ErrTXT = "- Ungültiges Zeichen: " & Chr(34) & Ch & Chr(34) & _
          vbNewLine & _
          "- Erlaubt sind: " & "0...9,  A...Z,  Ä, Ö, Ü"
          Exit Function
    End Select
    t1 = t1 & PR_FLD(Asc(Ch))
  Next i
 
  ' ---- Produkt-Summe mit Wichtungen 2...10, 2...9 bilden --------
  n = 0
  For i = 1 To Len(t1)
    Ch = Mid(t1, Len(t1) + 1 - i, 1)
    If i = 1 Or i = 10 Then
      ' Neu anfangen mit Wichtung 2 bei Pos.1 und Pos.10 von rechts
      n = 2
    End If
    PrSUMME = PrSUMME + Ch * n
    n = n + 1
  Next i
 
  PruefZifferVonFIN = ((PrSUMME / 11) - Fix(PrSUMME / 11)) * 11
  If PruefZifferVonFIN = 10 Then PruefZifferVonFIN = "X"
  Exit Function
 
ErrHandler:
  MsgBox "PruefZifferVonFIN(sFIN As String): " & Err.Number & "   " & Err.Description
End Function

US FIN
Quelle: http://en.wikibooks.org/wiki/Vehicle_Identification_Numbers_%28VIN_codes%29/Check_digit

Public Function PruefZifferVonVIN(sVIN, Optional ErrTXT As String = "") As String
  ' siehe Vehicle Identification Numbers (VIN codes)/Check digit
  ' http://en.wikibooks.org/wiki/Vehicle_Identification_Numbers_%28VIN_codes%29/Check_digit
  ' http://www.autocalculator.org/VIN/VIN-Checkdigit.aspx
  ' http://www.nhtsa.gov/cars/rules/maninfo/mcpkg002.pdf
 
  ' sVIN darf keine Klein-Buchstaben haben
  ' ErrTXT Rückgabe Fehlertext/ erstes nicht erlaubtes Zeichen
 
  ' Diese Berechnung ist nur für VIN(US)  !!!
  ' Bei europäischer FIN steht die Prüfziffer EXTRA rechts neben der FIN.
  ' Es gelten dabei andere Wichtungen bei den Produktbildungen für die einzelnen Positionen !!!
 
  On Error GoTo ErrHandler
 
  Dim i As Integer, n  As Integer
  Dim Ch As String * 1
  Dim t1 As String
  Dim PR_FLD(90)
  Dim PrSUMME As Long
 
  ' 2011-09-30 Abblocken wenn leere Bank  vbObject=9
  If VarType(sVIN) = vbObject Then Exit Function
  If Len("" & sVIN) = 0 Then Exit Function
 
  If Len(sVIN) <> 17 Then
    PruefZifferVonVIN = "?"
    ErrTXT = "Falsche Länge: " & Len(sVIN) & vbNewLine & _
      "Soll-Länge: 17"
    Exit Function
  End If
 
  ' ---- Uebersetzungen für Ziffern -----------
  For i = 48 To 57            '0...9
    PR_FLD(i) = Chr(i)
  Next i
 
  ' ---- Uebersetzungen für A...Z -------------
  For i = 65 To 90            'A...Z
    If Chr(i) = "A" Or Chr(i) = "J" Then  ' Neu Anfangen mit 1
      n = 1
    ElseIf Chr(i) = "S" Then              ' Neu Anfangen mit 2 !
      n = 2
    End If
    ' US: KEINE! Ausnahme Buchst. O -> 0 (Ziffer Null)
    PR_FLD(i) = n
    n = n + 1
  Next i
 
  ' ---- ZeichenFolge in Ziffern-Code-Folge uebersetzen ------------------
  t1 = ""
  For i = 1 To Len(sVIN)
    Ch = Mid(sVIN, i, 1)
    Select Case Asc(Ch)         ' US: KEINE Umlaute erlaubt ! Ä, Ö, Ü
      Case 48 To 57
        ' OK Ziffern 0...9
      Case 65 To 90
        ' OK Gross-Buchstaben A...Z
      Case Else
        If i <> 9 Then
         ' Fehler, nicht erlaubtes Zeichen
         ErrTXT = "- Ungültiges Zeichen: " & Chr(34) & Ch & Chr(34) & _
          vbNewLine & _
          "- Erlaubt sind: " & "0...9,  A...Z"
          Exit Function
       End If
    End Select
    If i = 9 Then
      t1 = t1 & Ch
    Else
      t1 = t1 & PR_FLD(Asc(Ch))
    End If
  Next i
 
  ' ---- Produkt-Summe mit Wichtungen 2...9, 0, 10, 2...8 bilden --------
  ' Dieser Code arbeitet mit Positionen von RECHTS nach LINKS (anders als in den VIN-Links):
  ' position   17   16  15  14  13  12  11  10  9   8   7   6   5   4   3   2   1
  ' factor      8   7   6   5   4   3   2   10  0   9   8   7   6   5   4   3   2
  n = 0
  For i = 1 To Len(t1)
    Ch = Mid(t1, Len(t1) + 1 - i, 1)
    Select Case i
      Case 1, 11  ' Neu anfangen mit Wichtung 2 bei Pos.1 und Pos.11 von rechts
        n = 2
      Case 10     ' 10 für Pos.10
        n = 10
    End Select
    If i <> 9 Then  ' Prüfziffer Pos.9 auslassen
      PrSUMME = PrSUMME + Ch * n
    End If
    n = n + 1
  Next i
 
  PruefZifferVonVIN = ((PrSUMME / 11) - Fix(PrSUMME / 11)) * 11
  If PruefZifferVonVIN = 10 Then PruefZifferVonVIN = "X"
  Exit Function
 
ErrHandler:
  MsgBox "PruefZifferVonVIN(sVIN As String): " & Err.Number & "   " & Err.Description
End Function

Beispiele:

Private Sub PruefZifferVonFIN_VIN_01()
  Dim t1 As String, ErrTXT As String
  Dim X
  ' ***** US-VINs *****************************************************
  ' t1 = "1M8GDM9A?KP042788"         ' US -> 1M8GDM9AXKP042788  (X)
  ' t1 = "SCEDT26T?BD003915"         ' US -> SCEDT26T8BD003915  (8)
  ' t1 = "SCCPC111x7HL30351"         ' US -> SCCPC11147HL30351  (4)
  ' t1 = "1G4AH59H.5G118341"         ' US -> 1G4AH59H45G118341  (4)
  ' t1 = "GH4AH59H.5G11834#"         ' Fehler #
  ' X = PruefZifferVonVIN(t1, ErrTXT)
 
  ' ***** EU-FINs *****************************************************
  t1 = "WBADR210X0GT30444"           ' EU -> (6)
  ' t1 = "WBADR210X0GT30444g"           ' Falsche Länge 18
  ' t1 = "A1BS31Z0430336179"            ' EU -> (4)
  ' t1 = "0LY341Ü59810IX"               ' EU -> (X)
  ' t1 = "0LY341Ü59810I~"               ' Fehler ~
  X = PruefZifferVonFIN(t1, ErrTXT)
 
  If Len(ErrTXT) > 0 Then
    MsgBox ErrTXT
  Else
    MsgBox "Prüfziffer: " & X
  End If
End Sub