Anbei sind 2 Funktionen:
Man kann damit zB. in einer Werkstatt bei der Fahrzeugannahme
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... Hier der Code incl. einer Testfunktion. Europäische FIN 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 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 19.658 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
Neu! sevDTA 3.0 Pro SEPA mit Kontonummernprüfung Erstellen von SEPA-Dateien mit integriertem BIC-Verzeichnis und Konto- nummern-Prüfverfahren, so dass ungültige Bankdaten bereits im Vorfeld ermittelt werden können. Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
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. |