Mit nachfolgendem Code lässt sich die Nummer eines deutschen Personalausweises auf Gültigkeit prüfen. Die Funktion prüft ermittelt hierzu die Prüfziffern der einzelnen Nummernblöcke und vergleicht diese mit der in der Nummer selbst angegebenen Prüfziffer. Optional lässt sich beim Aufruf der Funktion noch angeben, ob zusätzlich auch das Geburtsdatum sowie das Ablaufdatum auf korrekte Datumsangabe hin geprüft werden soll. Anmerkung: aaaabbbbbPD<<ccccccP<ddddddP<<<<<<<P
Und hier die Funkition PersoCheckNumber ' Prüft die Gültigkeit der angegebenen Personalsausweisnummer ' (nur für Deutschland!) Public Function PersoCheckNumber(ByVal sNumber As String, _ Optional ByVal bCheckDate As Boolean = False) As Boolean Dim bResult As Boolean ' alle "<"-Zeichen ausfiltern sNumber = Replace(sNumber, "<", "") ' Handelt es sich um einen deutschen Personalausweis? If Len(sNumber) = 26 And Mid$(sNumber, 11, 1) = "D" Then sNumber = Left$(sNumber, 10) & Mid$(sNumber, 12) ' Prüfziffer 1. Block (Behörde) If PersoGetPZ(Left$(sNumber, 9)) = Mid$(sNumber, 10, 1) Then ' GebDatum auf gültiges Datum prüfen If bCheckDate Then If Not PersoIsDate(Mid$(sNumber, 11, 6)) Then Exit Function End If ' Prüfziffer 2. Block (GebDatum) If PersoGetPZ(Mid$(sNumber, 11, 6)) = Mid$(sNumber, 17, 1) Then ' Ablaufdatum auf gültiges Datum prüfen If bCheckDate Then If Not PersoIsDate(Mid$(sNumber, 18, 6)) Then Exit Function End If ' Prüfziffer 3. Block (Ablaufdatum) If PersoGetPZ(Mid$(sNumber, 18, 6)) = Mid$(sNumber, 24, 1) Then ' Gesamtprüfziffer If PersoGetPZ(Mid$(sNumber, 1, 24)) = Mid$(sNumber, 25, 1) Then bResult = True End If End If End If End If End If PersoCheckNumber = bResult End Function ' Hilfsfunktion: Ermittelt die Prüfziffer der ' angegebenen Ziffernfolge Private Function PersoGetPZ(ByVal sNumber As String) As String Dim i As Long Dim bError As Boolean ReDim nSum(2) As Long For i = 1 To Len(sNumber) Select Case Asc(Mid$(sNumber, i, 1)) Case 48 To 57 ' nur Ziffern erlaubt! Case Else ' Prüfung abbrechen bError = True Exit For End Select Next i If Not bError Then ' Quersumme berechnen For i = 1 To Len(sNumber) Step 3 nSum(0) = nSum(0) + (Val(Mid$(sNumber, i, 1))) nSum(1) = nSum(1) + (Val(Mid$(sNumber, i + 1, 1))) nSum(2) = nSum(2) + (Val(Mid$(sNumber, i + 2, 1))) Next i PersoGetPZ = Right$(CStr(nSum(0) * 7 + nSum(1) * 3 + nSum(2)), 1) End If End Function ' Hilfsfunktion: Prüft, ob es sich um eine ' gültige Datumsangabe handelt Private Function PersoIsDate(ByVal sNumber As String) As Boolean Dim bResult As Boolean Dim nMonth As Long Dim nDay As Long nMonth = Val(Mid$(sNumber, 3, 2)) nDay = Val(Mid$(sNumber, 5, 2)) If nMonth > 0 And nMonth < 13 Then Select Case nMonth Case 1, 3, 5, 7, 8, 10, 12 If nDay > 0 And nDay < 32 Then bResult = True Case 2 If nDay > 0 And nDay < 30 Then bResult = True Case Else If nDay > 0 And nDay < 31 Then bResult = True End Select End If PersoIsDate = bResult End Function Dieser Tipp wurde bereits 14.517 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. |
sevWizard für VB5/6 Professionelle Assistenten im Handumdrehen Erstellen Sie eigene Assistenten (Wizards) im Look & Feel von Windows 2000/XP - mit allem Komfort und zwar in Windeseile :-) Tipp des Monats Juni 2024 Microsys Kramer Mausrad im Formular abschalten (Access) Deaktiviert das Mausrad in Access-Formularen. 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. |