VB如何实现实现的18位身份证格式验证算法

Question

VB如何实现18位身份证格式验证算法以及输入任意一个身份证号码效验是否符合身份证编码标准，请高手帮忙！谢谢

Answer 1

15位的身份证号
dddddd yymmdd xx p
18位的身份证号
dddddd yyyymmdd xx p y
其中dddddd为地址码（省地县三级）18位中的和15位中的不完全相同
yyyymmdd yymmdd 为出生年月日
xx顺号类编码
p性别
18位中末尾的y为校验码，在网上可以找到算法
将前17位的ascii码值经位移、异或运算结果不在0-9的令其为xhttp://www.pconline.com.cn/pcedu/empolder/db/0401/270819.html

Answer 2

http://www.pconline.com.cn/pcedu/empolder/db/0401/270819.html

Answer 3

Option ExplicitPrivate Sub Form_Load()
MsgBox Chk18("330000199004010001")
End
End SubPrivate Function Chk18(a As String) As Boolean
Dim b(1 To 18) As Integer
Dim i As Long
Dim Result As StringChk18 = TrueIf Len(a) <> 18 Then Chk18 = False: Result = "身份证位数不对！" & vbCrLf: GoTo aaFor i = 1 To 18
    b(i) = Mid(a, i, 1)
Nexti = (b(1) * 7 + b(2) * 9 + b(3) * 10 + b(4) * 5 + b(5) * 8 + b(6) * 4 + b(7) * 2 + b(8) * 1 + b(9) * 6 + b(10) * 3 + b(11) * 7 + b(12) * 9 + b(13) * 10 + b(14) * 5 + b(15) * 8 + b(16) * 4 + b(17) * 2) Mod 11Select Case i
    Case 0
        i = 1
    Case 1
        i = 0
    Case 2
        i = 10
    Case 3
        i = 9
    Case 4
        i = 8
    Case 5
        i = 7
    Case 6
        i = 6
    Case 7
        i = 5
    Case 8
        i = 4
    Case 9
        i = 3
    Case 10
        i = 2
End SelectIf b(18) <> i Then
    Result = Result & "验证码错误！" & vbCrLf
    Chk18 = False
End IfIf IsDate(b(7) & b(8) & b(9) & b(10) & "-" & b(11) & b(12) & "-" & b(13) & b(14)) = False Then
    Result = Result & "生日错误！" & vbCrLf
    Chk18 = False
End Ifaa:
If Len(Result) <> 0 Then MsgBox Result
End Function

Answer 4

Public Type AboutIdCard
  Place As String '地区
  Sex As String '性别
  Birthday As Date '生日
  sErrInfo As String '错误信息
End TypePublic 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 LongGetPersonInfo = ""
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前提是你需要有用户的身份证编码文本~~
判断是否为有效身份证号码：
ption ExplicitPrivate 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 FunctionPrivate Sub Command1_Click()
    Dim tempstr As String
    tempstr = Trim(Text1.Text)
    If zh15to18(tempstr) Then
       Text2.Text = tempstr
    End If
End Sub

Answer 5

http://search.csdn.net/Expert/topic/2260/2260487.xml?temp=.9788629

Answer 6

http://search.csdn.net/Expert/topic/1945/1945337.xml?temp=.8208124