'================================计算身份证第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