Access数字阶乘

时　间:2018-03-22 09:06:11
作　者:张义成   ID：37928  城市：赤峰
摘　要:Access数字阶乘
正　文:

自然数阶乘的传值传址函数与递归运算方法，模拟 Val 函数常用功能并增强提取数字能力。

代   码:
Option Compare Database
Option Explicit
Dim varTiquShuzi As Variant

Rem -----------
Rem 编者 张义成
Rem 日期 2018-03-21
Rem 功能 自然数阶乘的传值传址函数与递归运算方法，模拟 Val 函数常用功能并增强提取数字能力。
Rem -----------
Rem 控件属性 重要设置：
Rem Txt传值数字：格式 空白。小数位数 自动。是否锁定 否。制表位 是。
Rem Txt传址数字：格式 空白。小数位数 自动。是否锁定 否。制表位 是。
Rem Txt阶乘数字：格式 标准。小数位数 自动。是否锁定 是。制表位 否。
Rem Txt提取数字：格式 标准。小数位数 自动。是否锁定 是。制表位 否。
Rem -----------

Private Sub Form_Load()
On Error GoTo ErrorHandler

        Txt传值数字 = "- 0,0..。170,.a。5。."
        Txt传址数字 = "..-- ..0,21.47-a-48。36.46.。012345。."
        
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub Cmd重置_Click()
On Error GoTo ErrorHandler

        DoCmd.ShowAllRecords
        Txt传值数字 = "- 0,0..。170,.a。5。."
        Txt传址数字 = "..-- ..0,21.47-a-48。36.46.。012345。."
        Txt阶乘数字 = Null
        Txt提取数字 = Null
        varTiquShuzi = Empty
        
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub Txt传值数字_AfterUpdate()
On Error GoTo ErrorHandler

        Txt传址数字 = Null
        Txt提取数字 = Null
        
    If IsNull(Txt传值数字) Then
        Txt传值数字 = Null
        Txt阶乘数字 = Null
       Exit Sub
    End If
    
        Dim lngShuZi As Long '数字（长整型）
        Dim dblJieCheng As Double '阶乘（双精型）
        Dim varShuJu As Variant '数据（变体型）
        Dim varShuZi As Variant '数字（变体型）
            varShuJu = Txt传值数字
            varShuZi = funvarShuJu(varShuJu) '调用函数
            Txt提取数字 = varTiquShuzi '显示通用声明变量
            
    If IsNumeric(varShuZi) Then
        If varShuZi = 0 Then '阶乘定义： 0! = 1  fact(0) = 1
            Txt传值数字 = 0
            Txt阶乘数字 = 1
            Exit Sub
        ElseIf varShuZi > 0 And varShuZi <= 2147483647 Then
                lngShuZi = CLng(varShuZi) '只能在此转换，不许提前转换！否则会因运算数字超限而先期溢出！
            If lngShuZi = 0 Then '阶乘定义： 0! = 1  fact(0) = 1
                Txt传值数字 = 0
                Txt阶乘数字 = 1
                Exit Sub
            End If
            If lngShuZi >= 171 Then
                Txt传值数字 = lngShuZi
                Txt阶乘数字 = Null
                Dim strP As String, strT As String
                    strP = strP & "运算数字 大于等于 171 时，" & vbCrLf
                    strP = strP & "阶乘数字 已经超过 双精型上限值：" & vbCrLf
                    strP = strP & "1.79769313486232E308，" & vbCrLf
                    strP = strP & "溢出 ！"
                    strT = "郑重提示"
                MsgBox strP, vbExclamation, strT
                Exit Sub
            End If
                Txt传值数字 = lngShuZi
                dblJieCheng = fundblJieCheng(lngShuZi) '调用函数
                Txt阶乘数字 = dblJieCheng
        ElseIf varShuZi > 2147483647 Then
            Txt传值数字 = varShuZi
            Txt阶乘数字 = Null
            MsgBox "运算数字 已经超过 长整型上限值 2147483647，溢出 ！", vbExclamation, "郑重提示"
            Exit Sub
        ElseIf varShuZi < 0 Then '负数应该不存在！此前已将负号全部舍弃了！
            Txt传值数字 = varShuZi
            Txt阶乘数字 = Null
            MsgBox "运算数字 必须是 正数 哦 ！", vbInformation, "温馨提示"
            Exit Sub
        Else
            Txt传值数字 = varShuZi
            Txt阶乘数字 = Null
            MsgBox "代码设计 存在缺陷 哦 ！", vbExclamation, "郑重提示"
            Exit Sub
        End If
    Else
        Txt传值数字 = varShuZi
        Txt阶乘数字 = Null
        MsgBox "运算数字 必须是 阿拉伯数字 和 小数点 哦 ！", vbExclamation, "郑重提示"
        Exit Sub
    End If
    
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub


Private Sub Txt传址数字_AfterUpdate()
On Error GoTo ErrorHandler

        Txt传值数字 = Null
        Txt提取数字 = Null
        
    If IsNull(Txt传址数字) Then
        Txt传址数字 = Null
        Txt阶乘数字 = Null
        Exit Sub
    End If
    
        Dim lngShuZi As Long '数字（长整型）
        Dim dblFactorial As Double '阶乘（双精型）
        Dim varShuJu As Variant '数据（变体型）
        Dim varShuZi As Variant '数字（变体型）
            varShuJu = Txt传址数字
            varShuZi = funvarShuJu(varShuJu) '调用函数
            Txt提取数字 = varTiquShuzi '显示通用声明变量
            
    If IsNumeric(varShuZi) Then
        If varShuZi = 0 Then '阶乘定义： 0! = 1  fact(0) = 1
            Txt传址数字 = 0
            Txt阶乘数字 = 1
            Exit Sub
        ElseIf varShuZi > 0 And varShuZi <= 2147483647 Then
                lngShuZi = CLng(varShuZi) '只能在此转换，不许提前转换！否则会因运算数字超限而先期溢出！
            If lngShuZi = 0 Then '阶乘定义： 0! = 1  fact(0) = 1
                Txt传址数字 = 0
                Txt阶乘数字 = 1
                Exit Sub
            End If
            If lngShuZi >= 171 Then
                Txt传址数字 = lngShuZi
                Txt阶乘数字 = Null
                Dim strP As String, strT As String
                    strP = strP & "运算数字 大于等于 171 时，" & vbCrLf
                    strP = strP & "阶乘数字 已经超过 双精型上限值：" & vbCrLf
                    strP = strP & "1.79769313486232E308，" & vbCrLf
                    strP = strP & "溢出 ！"
                    strT = "郑重提示"
                MsgBox strP, vbExclamation, strT
                Exit Sub
            End If
                Txt传址数字 = lngShuZi
                dblFactorial = fundblFactorial(lngShuZi) '调用函数
                Txt阶乘数字 = dblFactorial
        ElseIf varShuZi > 2147483647 Then
            Txt传址数字 = varShuZi
            Txt阶乘数字 = Null
            MsgBox "运算数字 已经超过 长整型上限值 2147483647，溢出 ！", vbExclamation, "郑重提示"
            Exit Sub
        ElseIf varShuZi < 0 Then '负数应该不存在！此前已将负号全部舍弃了！
            Txt传址数字 = varShuZi
            Txt阶乘数字 = Null
            MsgBox "运算数字 必须是 正数 哦 ！", vbInformation, "温馨提示"
            Exit Sub
        Else
            Txt传址数字 = varShuZi
            Txt阶乘数字 = Null
            MsgBox "代码设计 存在缺陷 哦 ！", vbExclamation, "郑重提示"
            Exit Sub
        End If
    Else
        Txt传址数字 = varShuZi
        Txt阶乘数字 = Null
        MsgBox "运算数字 必须是 阿拉伯数字 和 小数点 哦 ！", vbExclamation, "郑重提示"
        Exit Sub
    End If
    
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Function funvarShuJu(ByVal varVariable As Variant) As Variant

        Rem 被以下两个事件共同调用：
        Rem Txt传址数字_AfterUpdate
        Rem Txt传值数字_AfterUpdate
        
        Rem ByVal 传值
        Rem funvarShuJu  数据（变体型） 函数名称
        Rem varVariable  变量（变体型）
        
        Rem 连续三个小数点“...”将被系统自动转换为 连续三个中圆点“…” 亦即省略号
        
    Dim varZiFu As Variant '字符（变体型）
    Dim varZuHe As Variant '组合（变体型）
    
    Dim x As Long
    Dim y As Long
    
        Rem 清除空格
        varVariable = Replace(varVariable, " ", "")
        
        Rem -----------
        Rem 提取 数字 小数点，舍弃其它任何冗余字符（包括负号句号“-。”）
        'x = 1: y = Len(varVariable)
    'For x = x To y
        'varZiFu = Mid(varVariable, x, 1)
        'If varZiFu Like "[0-9.]" Then varZuHe = varZuHe & varZiFu
    'Next
        Rem -----------
        
        Rem 提取 数字 小数点 句号，舍弃其它任何冗余字符（包括负号“-”）
        x = 1: y = Len(varVariable)
    For x = x To y
        varZiFu = Mid(varVariable, x, 1)
        If varZiFu Like "[0-9.。]" Then varZuHe = varZuHe & varZiFu
    Next
    
        Rem 将 句号 替换为 小数点，在此前已经提取 句号 的情况下启用
        varZuHe = Replace(varZuHe, "。", ".")
        
        Rem 将 连续多个小数点 替换为 单个小数点
    While varZuHe Like "*" & ".." & "*"
        varZuHe = Replace(varZuHe, "..", ".")
    Wend
    
        Rem 舍弃末尾 小数点
    If Right(varZuHe, 1) = "." Then
        varZuHe = Left(varZuHe, Len(varZuHe) - 1)
    End If
    
        Rem 清除左边冗余的小数点，仅留最右边的一个小数点
    While varZuHe Like "*" & "." & "*" & "." & "*"
        Mid(varZuHe, InStr(varZuHe, "."), 1) = "," '将冗余小数点临时性替换为逗号（或其它符号）
    Wend
        varZuHe = Replace(varZuHe, ",", "") '将逗号替换为空字符串
        
        Rem -----------
        Rem 添加负号“-”，人为制造麻烦，故意引发错误！应在测试后将其屏蔽或删除！
        'varZuHe = "-" & varZuHe '
        Rem -----------
        
        Rem 设置函数返回值
        funvarShuJu = varZuHe
        
        Rem 为通用声明变量 varTiquShuzi 赋值，此项为额外附加内容！
        varTiquShuzi = varZuHe
        
End Function

Private Function fundblJieCheng(ByVal lngVariable As Long) As Double

        Rem 被 Txt传值数字_AfterUpdate 调用
        
        Rem ByVal 传值
        Rem fundblJieCheng 阶乘（双精型） 函数名称
        Rem lngVariable    变量（长整型）
        
        lngVariable = lngVariable - 1
    If lngVariable = 0 Then
        fundblJieCheng = 1
        Exit Function
    End If
        fundblJieCheng = fundblJieCheng(lngVariable) * (lngVariable + 1)
        
End Function

Private Function fundblFactorial(ByRef lngVariable As Long) As Double


        Rem 被 Txt传址数字_AfterUpdate 调用
        
        Rem ByRef 传址 默认省略
        Rem fundblFactorial 阶乘（双精型） 函数名称
        Rem lngVariable     变量（长整型）
        
    If lngVariable = 0 Then
        fundblFactorial = 1
        Exit Function
    End If
        fundblFactorial = fundblFactorial(lngVariable - 1) * lngVariable
        
End Function

Private Sub Cmd重启_Click()
On Error GoTo ErrorHandler

    DoCmd.ShowAllRecords
    Dim strFormName As String
        strFormName = Screen.ActiveForm.Name
    DoCmd.Close
    DoCmd.OpenForm strFormName
    
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    Resume ErrorHandlerExit
End Sub

Private Sub Cmd关闭_Click()
On Error GoTo ErrorHandler

    DoCmd.ShowAllRecords
    DoCmd.Close
    
ErrorHandlerExit:
    Exit Sub
ErrorHandler:
    MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    Resume ErrorHandlerExit

End Sub

附   件:

点击下载此附件

图   示:

Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店