通过身份号码查询出生日期、性别的设计-贺德才专栏

利用身份证号码查看其人的出生年月及性别等情况，这在excel是可以实现的。这里介绍用access实现的代码，供access爱好者参考，同时提供本人设计的一个身份证号码查询的程序供大家下载使用。想来肯定有用得上的时候。时常有报道说某犯罪嫌疑人用假身份证犯罪，我想相关机关或单位如果有我这样一个身份证查询程序，查一下身份证，问几个问题，犯罪分子应该立马露馅。程序原码如下－－

Private Sub txtStatusCode_AfterUpdate()
Dim AreaCode, Area, BirthDay, NewCode As String
Dim Calendar As Date

On Error Resume Next

Me.cmdToEdit.SetFocus

Me.txtBirthDay = Null
Me.txtGivePassArea = Null
Me.txtSex = Null
Me.txtStatusCodeNew = Null
Me.txtAge = Null

'检查身份证号码位数
If CheckLength(Me.txtStatusCode) = False Then
    MsgBox ("身份证号码的位数出现错误.")
    Me.txtStatusCode.SetFocus
    Exit Sub
End If

'检查身份证号码中有无非法字符
If CheckChar(Me.txtStatusCode) = False Then
    MsgBox ("身份证号码中含有非法字符.")
    Me.txtStatusCode.SetFocus
    Exit Sub
End If

'检查地区代码
If CheckArea(Mid(Me.txtStatusCode, 1, 6)) = False Then
Exit Sub
End If

Area = ""
AreaCode = Mid(Me.txtStatusCode, 1, 6) '取得地区代码

'取得发证地区名称
Area = Area & DLookup("[名称]", "地区代码", "[代码]='" & Mid(AreaCode, 1, 2) & "0000'")
Area = Area & DLookup("[名称]", "地区代码", "[代码]='" & Mid(AreaCode, 1, 4) & "00'")
Area = Area & DLookup("[名称]", "地区代码", "[代码]='" & AreaCode & "'")

'如果身份证号码位数是十五位则增至十七位
If Len(Me.txtStatusCode) = 15 Then
    NewCode = Mid(Me.txtStatusCode, 1, 6) & "19" & Right(Me.txtStatusCode, 9)
Else
    NewCode = Me.txtStatusCode
End If

'校验出生日期
BirthDay = Mid(NewCode, 7, 4) & "-" & _
    Mid(NewCode, 11, 2) & "-" & Mid(NewCode, 13, 2)
Calendar = DateValue(BirthDay)
If Err() = 13 Then
    MsgBox ("身份证号码中的出生日期部分错误.")
    Me.txtStatusCode.SetFocus
    Exit Sub
End If

Err() = 0

'可以根据情况设置年龄的上下限,这里是:年龄[0,100]
If Year(Date) - Year(BirthDay) > 100 or _
    Year(Date) - Year(BirthDay) < 0 or _
    Year(BirthDay) > Year(Date) Then
    MsgBox ("身份证号码中的出生日期部分错误.")
    Me.txtStatusCode.SetFocus
    Exit Sub
End If

'校验身份证号码并生成有效的身份证号码
NewCode = ""
NewCode = MakeNewCode(Me.txtStatusCode)

'显示结果
Me.txtStatusCodeNew = NewCode
Me.txtBirthDay = BirthDay
Me.txtGivePassArea = Area
Me.txtSex = IIf(InStr(1, "13579", Right(Me.txtStatusCode, 1)) <> 0, "男", "女")
Me.txtAge = Year(Date) - Year(BirthDay)

Me.txtStatusCode.SetFocus

End Sub

Public Function CheckChar(strCode As String) As Boolean
Dim I As Integer
Dim J As Integer

If Len(strCode) = 18 Then
J = 17
Else
J = Len(strCode)
End If

For I = 1 To J
    If Asc(Mid(Me.txtStatusCode, I, 1)) > 57 or _
        Asc(Mid(Me.txtStatusCode, I, 1)) < 48 Then
        CheckChar = False
        Exit Function
    End If
Next I

If Len(strCode) = 18 Then
If Asc(UCase(Right(strCode, 1))) > 57 or