vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Top-Preis! AP-Access-Tools-CD Volume 1  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2018
 
zurück
Rubrik: Variablen/Strings · Algorithmen/Mathematik   |   VB-Versionen: VB608.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ädtBewertung:     [ Jetzt bewerten ]Views:  11.166 
ohne HomepageSystem:  WinXP, Vista, Win7, Win8, Win10 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

Dieser Tipp wurde bereits 11.166 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2018 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel