Access开发培训
网站公告
·Access专家课堂QQ群号:151711184    ·Access快速开发平台下载地址及教程    ·欢迎加入Access专家课堂微信群!    ·如何快速搜索本站文章|示例|资料    
您的位置: 首页 > 技术文章 > 源码示例

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源码网店

常见问答:

技术分类:

相关资源:

专栏作家

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助