Access数字阶乘-张义成
Access软件网QQ交流学习群(群号码198465573),欢迎您的加入!
首页 >技术文章> 源码示例


Access数字阶乘

发表时间:2018/3/22 9:06:11 评论(2) 浏览(6217)  评论 | 加入收藏 | 复制
   
摘 要: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群(群号:198465573)
 
 相关文章
【access小品】蜻蜓咬尾---多端点配线路径递归计算示例  【煮江品茶  2012/2/26】
【Access函数】列表文件递归  【亚伦·布朗  2012/8/30】
【Access小品】越俎代庖--递归函数示例,Access树控件制...  【煮江品茶  2015/6/4】
用VB递归算法实现BOM展开的树型结构操作  【梁志强,谢菁  2017/4/14】
Sql递归(用with 实现)  【MDZZ  2018/2/26】
常见问答
技术分类
相关资源
文章搜索
关于作者

张义成

文章分类

文章存档

友情链接