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.602 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! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
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. |