推荐：身份证号码的实用函数

我向大家推荐一个身份证号码的实用函数,功能：

A. 15 位 升为 18 位，返回新的 18 位新号码。

B. 检验录入的 18 位是否符合规则， 返回 18 位新号码。 （新旧相同）

C. 如果有错误， 返回 4 种 错误提示。

D. 根据情况不同，一共有 6 种 返回值！ 实际使用时，判断返回值的第1，2个字符，来决定下面的代码如何写。
E. 程序员可以根据另行需要，改写下面的代码就行了。

这个函数在论坛中原先有过介绍，但都不是实用函数，用起来比较别扭，麻烦。 经过我改写后，具有很强的实用效能。

只要把下面的代码（一字不改）粘贴到“模块”即可，模块的名称任意， 然后在任何窗体都可以调用了。

非常感谢原代码的提供者！

Function TRSFZ(strIN As String) As String      '''A. 15位升18位， B. 检验18位是否正确！ 返回 TRSFZ()  4 种错误，都是 E 打头！
    On Error Resume Next
    Dim strIN加年 As String
    Dim Calendar As Date
   
    '1. 检查身份证号码位数
    If Len(strIN) <> 15 And Len(strIN) <> 18 Then
        TRSFZ = "E1位数不对:" & Len(strIN)
        Exit Function
    End If

    '2. 检查身份证号码中有无非法字符
    Dim I As Integer
    Dim J As Integer
    If Len(strIN) = 18 Then
        J = 17
    Else
        J = Len(strIN)
    End If

    For I = 1 To J
        If Asc(Mid(strIN, I, 1)) > 57 Or Asc(Mid(strIN, I, 1)) < 48 Then
            TRSFZ = "E2有非法字符:" & Mid(strIN, I, 1)
            Exit Function
        End If
    Next I

    '3. 如果身份证号码位数是十五位则增至十七位
    If Len(strIN) = 15 Then
        strIN加年 = Mid(strIN, 1, 6) & "19" & Right(strIN, 9)  ''' if 15 变成 17 位
    Else
        strIN加年 = strIN  ''' 18 位 或 17 位 保持不变！
    End If

    '校验出生日期
    Calendar = DateValue(Mid(strIN加年, 7, 4) & "-" & Mid(strIN加年, 11, 2) & "-" & Mid(strIN加年, 13, 2))
    If Err() = 13 Then
        TRSFZ = "E3生日错" & Mid(strIN加年, 7, 4) & "-" & Mid(strIN加年, 11, 2) & "-" & Mid(strIN加年, 13, 2)
        Exit Function
    End If
    Err() = 0

    '校验身份证号码并生成有效的 18 位身份证号码
    Dim strCodeX As String, NewCode As String
    I = 0
    If Len(strIN加年) = 18 Then
        strCodeX = Mid(strIN加年, 1, 17)
    Else
        strCodeX = strIN加年
    End If

    '生成第十八位校验码
    Dim Wi, Ai, WiAi As Integer
    Wi = 0
    Ai = 0
    WiAi = 0
    For I = 18 To 1 Step -1
        Ai = Val(Mid(strCodeX, 19 - I, 1))
        Wi = (2 ^ (I - 1)) Mod 11
        WiAi = WiAi + Wi * Ai
    Next I
    WiAi = WiAi Mod 11
    Select Case WiAi
    Case 0
        NewCode = strCodeX & "1"
    Case 1
        NewCode = strCodeX & "0"
    Case 2
        NewCode = strCodeX & "X"
    Case 3
        NewCode = strCodeX & "9"
    Case 4
        NewCode = strCodeX & "8"
    Case 5
        NewCode = strCodeX & "7"
    Case 6
        NewCode = strCodeX & "6"
    Case 7
        NewCode = strCodeX & "5"
    Case 8
        NewCode = strCodeX & "4"
    Case 9
        NewCode = strCodeX & "3"
    Case 10
        NewCode = strCodeX & "2"
    End Select
    If Len(strIN) = 18 Then
        If strIN <> NewCode Then
            TRSFZ = "E4原先的18位有误 " & NewCode   ''' 返回：错误提示+新号码
        Else
            TRSFZ = NewCode      '''返回： 检验原18位合格 ， 返回： 18位号码
        End If
    Else
        TRSFZ = NewCode          '''返回： 15 转 18 位 的 新号码
    End If
    ''' 根据情况不同，一共有 6 种 返回值！
    ''' 实际使用时，判断返回值的第1，2个字符，来决定下面的代码如何写。
End Function