身份证号的校检代码

 
'================================计算身份证第18位校检码

Public Type AboutIdCard
    Place   As String     '地区
    Sex   As String     '性别
    Birthday   As Date     '生日
    sErrInfo   As String     '错误信息
End Type

Public Function GetPersonInfo(CodePath As String, idcard As String, BackInfo As AboutIdCard) As String
    '根据〖中华人民共和国国家标准   GB   11643-1999〗中有关公民身份号码的规定，
    '公民身份号码是特征组合码18位：由十七位数字本体码和一位数字校验码组成。排列顺序从左至右依次为：六位数字地址码，八位数字出生日期码，三位数字顺序码和一位数字校验码。
    '地址码表示编码对象常住户口所在县(市、旗、区)的行政区划代码。生日期码表示编码对象出生的年、月、日，其中年份用四位数字表示，年、月、日之间不用分隔符。顺序码表示同一地址码所标识的区域范围内，对同年、月、日出生的人员编定的顺序号。顺序码的奇数分给男性，偶数分给女性。
    '15位：六位数字地址码，六位数字出生日期码，三位数字顺序码和一位数字校验码。
    On Error GoTo Err:

    Dim PlaceCode     As String
    Dim strPlace     As String
    Dim strCode     As String
    Dim sDate     As String
    Dim FileNumber     As Long

    GetPersonInfo = ""
    BackInfo.sErrInfo = ""
    If Len(idcard) <> 15 And Len(idcard) <> 18 Then
        BackInfo.sErrInfo = "身份证长度错误"
    End If
    '判断日期/转换成为日期,出错跳转
    If Len(idcard) = 15 Then
        sDate = Mid(idcard, 7, 2) & "-" & Mid(idcard, 9, 2) & "-" & Mid(idcard, 11, 2)
        BackInfo.Birthday = Format(sDate, "yyyy-mm-dd")
        If CLng(Mid(idcard, 13, 3)) Mod 2 = 0 Then                   '取得性别
            BackInfo.Sex = "女"
        Else
            BackInfo.Sex = "男"
        End If
    Else
        sDate = Mid(idcard, 7, 4) & "-" & Mid(idcard, 11, 2) & "-" & Mid(idcard, 13, 2)
        BackInfo.Birthday = sDate
        If CLng(Mid(idcard, 15, 3)) Mod 2 = 0 Then                   '取得性别
            BackInfo.Sex = "女"
        Else
            BackInfo.Sex = "男"
        End If
    End If
    PlaceCode = Mid(idcard, 1, 6)
    If IsNumeric(PlaceCode) = False Then
        BackInfo.sErrInfo = "身份证编码错误"
        Exit Function
    End If
    FileNumber = FreeFile
    Open CodePath For Input As #FileNumber
    Do While Not EOF(FileNumber)
        Input #FileNumber, strCode, strPlace
        If strCode = PlaceCode Then
            BackInfo.Place = strPlace
            Close #FileNumber
            Exit Function
        End If
    Loop
    Close #FileNumber
    BackInfo.Place = "编码未知"       '不算错误

Exit Function

Err:
    BackInfo.sErrInfo = "非法身份证号码"
End Function

Public Function zh15to18(str1 As String) As Boolean
    Dim oldstr     As String

    Dim Is_sfzh     As String
    Dim Is_checkcode     As String
    Dim ll_code(17)     As Long
    Dim ll_sum     As Long
    Dim i     As Integer
    Dim li_number     As Integer
    ll_sum = 0
    oldstr = str1
    If Not IsNumeric(Left(str1, 17)) Then
        MsgBox "不是有效身份证号码"
        zh15to18 = False
        Exit Function
    End If
    If Len(str1) = 15 Then
        If IsDate(Mid(str1, 7, 2) & "-" & Mid(str1, 9, 2) & "-" & Mid(str1, 11, 2)) Then
            If Int(Mid(str1, 7, 2)) > 30 Then
                str1 = Mid(str1, 1, 6) & Replace(str1, Mid(str1, 7, 2), "19" & Mid(str1, 7, 2), 7, 1)
                zh15to18 = True
            Else
                str1 = Mid(str1, 1, 6) & Replace(str1, Mid(str1, 7, 2), "20" & Mid(str1, 7, 2), 7, 1)

            End If
        Else
            MsgBox "身份证号中日期   " & Mid(str1, 7, 6) & "非法"
            zh15to18 = False
            Exit Function
        End If
    ElseIf Len(str1) = 18 Then
        If Not IsDate(Mid(str1, 7, 4) & "-" & Mid(str1, 11, 2) & "-" & Mid(str1, 13, 2)) Then
            MsgBox "身份证号中日期   " & Mid(str1, 7, 8) & "非法"
            Exit Function
        End If

    End If

    For i = 1 To 17
        '得到加权因子值     wi=2   ^(i-1)   mod   11   [i   18   -2   ]
        ll_code(i) = (2 ^ (18 - i)) Mod 11
        li_number = Val(Mid(str1, i, 1))
        ll_sum = ll_sum + ll_code(i) * li_number
    Next
    Is_checkcode = Trim(Str((ll_sum Mod 11)))
    Select Case Is_checkcode
      Case "2"
        Is_checkcode = "x"
      Case "0", "1"
        Is_checkcode = Str(0 ^ Int(Is_checkcode))
      Case Else
        Is_checkcode = Str(12 - Val(Trim(Is_checkcode)))
    End Select

    If Len(str1) = 18 Then
        If Right(str1, 1) <> Trim(Is_checkcode) Then
            MsgBox "身份证号码校" & Is_checkcode & "未通过"
            zh15to18 = False
            Exit Function
        End If
    Else
        If Len(str1) <> 17 Then zh15to18 = False
        str1 = Trim(str1) & Trim(Is_checkcode)

    End If
    zh15to18 = True
End Function

'========================判断身份证号码有效性

Public Function Func_PersonIdValidate(PersonIdTemp As String) As Integer
    Dim strTemp As String, FuncStr As String
    Func_PersonIdValidate = 0 '表示身份证正确
   
    '判断身份证号长度
    If Len(PersonIdTemp) <> 15 And Len(PersonIdTemp) <> 18 Then
        Func_PersonIdValidate = 1             '身份证长度错误
        Exit Function
    End If
   
    '字符有效性，字符有效性校验已在keypress中存在，此处仅为防止copy字串含有非法字串
    Select Case Len(PersonIdTemp)
      Case 15
        If Not IsNumeric(Trim(PersonIdTemp)) Then
            Func_PersonIdValidate = 2             '表示身份证有非法字符
            Exit Function
        End If
      Case 18
        If Not IsNumeric(Mid(PersonIdTemp, 1, 17)) Then
            Func_PersonIdValidate = 2             '表示身份证有非法字符
            Exit Function
        End If
        strTemp = Trim(Mid(PersonIdTemp, 18, 1))
        If Not IsNumeric(strTemp) And strTemp <> "x" And strTemp <> "X" Then
            Func_PersonIdValidate = 2             '表示身份证有非法字符
            Exit Function
        End If
    End Select
   
    '日期校验
    Select Case Len(PersonIdTemp)
      Case 15
        strTemp = "19" + Mid(PersonIdTemp, 7, 2) + "-" + Mid(PersonIdTemp, 9, 2) + "-" + Mid(PersonIdTemp, 11, 2)
      Case 17, 18
        strTemp = Mid(PersonIdTemp, 7, 4) + "-" + Mid(PersonIdTemp, 11, 2) + "-" + Mid(PersonIdTemp, 13, 2)
    End Select
   
    If Not IsDate(strTemp) Then
       Func_PersonIdValidate = 3
       Exit Function     '表示日期非法
    End If
   
    If Len(PersonIdTemp) = 18 Then
        FuncStr = Func_TheLastValidChar(PersonIdTemp)  '转到校验码正确性校验
        If UCase(Mid(PersonIdTemp, 18, 1)) <> FuncStr Then
            Func_PersonIdValidate = 4       '表示身份证校验码错误
        End If
    End If
End Function

Public Function Func_TheLastValidChar(PersonIdTemp As String) As String  '校验码正确性校验
    Dim intTemp As Integer
    intTemp = (7 * CInt(Mid(PersonIdTemp, 1, 1)) + _
               9 * CInt(Mid(PersonIdTemp, 2, 1)) + _
              10 * CInt(Mid(PersonIdTemp, 3, 1)) + _
               5 * CInt(Mid(PersonIdTemp, 4, 1)) + _
               8 * CInt(Mid(PersonIdTemp, 5, 1)) + _
               4 * CInt(Mid(PersonIdTemp, 6, 1)) + _
               2 * CInt(Mid(PersonIdTemp, 7, 1)) + _
               1 * CInt(Mid(PersonIdTemp, 8, 1)) + _
               6 * CInt(Mid(PersonIdTemp, 9, 1)) + _
               3 * CInt(Mid(PersonIdTemp, 10, 1)) + _
               7 * CInt(Mid(PersonIdTemp, 11, 1)) + _
               9 * CInt(Mid(PersonIdTemp, 12, 1)) + _
              10 * CInt(Mid(PersonIdTemp, 13, 1)) + _
               5 * CInt(Mid(PersonIdTemp, 14, 1)) + _
               8 * CInt(Mid(PersonIdTemp, 15, 1)) + _
               4 * CInt(Mid(PersonIdTemp, 16, 1)) + _
               2 * CInt(Mid(PersonIdTemp, 17, 1))) Mod 11
    Select Case intTemp
      Case 0
        Func_TheLastValidChar = "1"
      Case 1
        Func_TheLastValidChar = "0"
      Case 2
        Func_TheLastValidChar = "X"
      Case 3
        Func_TheLastValidChar = "9"
      Case 4
        Func_TheLastValidChar = "8"
      Case 5
        Func_TheLastValidChar = "7"
      Case 6
        Func_TheLastValidChar = "6"
      Case 7
        Func_TheLastValidChar = "5"
      Case 8
        Func_TheLastValidChar = "4"
      Case 9
        Func_TheLastValidChar = "3"
      Case 10
        Func_TheLastValidChar = "2"
    End Select
End Function