Access不同量级双精型数值的生成方法

时　间:2018-03-06 12:43:46
作　者:张义成   ID：37928  城市：赤峰
摘　要:Access不同量级双精型数值的生成方法
正　文:

附   件:

点击下载此附件

图   示:

代   码:

Option Compare Database

Option Explicit

Rem 编者 张义成
Rem 日期 2018-03-06
Rem 功能 不同量级双精型数值的生成方法

Private Sub Form_Load()
On Error GoTo ErrorHandler
        Lab四九.Caption = "  序号创建 9999   最快 15秒"
        Lab五九.Caption = "  序号创建 99999  最快 1分40秒"
        Lab六九.Caption = "  序号创建 999999 最快 19分20秒"
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！" & vbCrLf & vbCrLf & "不用删除，直接退出。", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
        Dim prompt As String, Title As String, Result As Integer
            prompt = prompt & "程序将要" & vbCrLf
            prompt = prompt & "删除 表中 全部记录！" & vbCrLf & vbCrLf
            prompt = prompt & "选择 确定， 删除。（默认）" & vbCrLf
            prompt = prompt & "选择 取消， 不删除，退出。"
            Title = "温馨提示"
            Result = MsgBox(prompt, vbOKCancel + vbInformation, Title)
        If Result = vbOK Then
                DoCmd.SetWarnings False  '关闭系统消息
            DoCmd.RunSQL "DELETE tbl号码.* FROM tbl号码"
                DoCmd.SetWarnings True   '打开系统消息
            Me.Requery
            MsgBox "已经删除 全部记录！", vbInformation, "温馨提示"
        Else
            Txt空白.SetFocus
            Exit Sub
        End If
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
        Resume ErrorHandlerExit
End Sub

Private Sub Cbo序号导入_AfterUpdate()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        Dim intMsg As Integer
            intMsg = MsgBox("表中 尚无记录呢！" & vbCrLf & vbCrLf & _
                            "是否 导入序号？" & vbCrLf & vbCrLf & _
                            "选择 是， 导入。（默认）" & vbCrLf & _
                            "选择 否， 不导入，退出。", vbYesNo + vbInformation, "温馨提示")
        If intMsg = vbNo Then
            Cbo序号导入 = Null
            Txt空白.SetFocus
            Exit Sub
        End If
    ElseIf lngCount > 0 Then
        Dim prompt As String, Title As String, Result As Integer
            prompt = prompt & "表中 尚有记录呢！" & vbCrLf
            prompt = prompt & "应该 先删除 再导入！" & vbCrLf & vbCrLf
            prompt = prompt & "是否 删除 表中 全部记录？" & vbCrLf & vbCrLf
            prompt = prompt & "选择 是， 删除。（默认）" & vbCrLf
            prompt = prompt & "选择 否， 不删除，退出。"
            Title = "温馨提示"
            Result = MsgBox(prompt, vbYesNo + vbInformation, Title)
        If Result = vbYes Then
                DoCmd.SetWarnings False  '关闭系统消息
            DoCmd.RunSQL "DELETE tbl号码.* FROM tbl号码"
                DoCmd.SetWarnings True   '打开系统消息
            Me.Requery
            If MsgBox("已经删除 全部记录！" & vbCrLf & vbCrLf & _
                    "是否 导入序号？" & vbCrLf & vbCrLf & _
                    "选择 是， 导入。（默认）" & vbCrLf & _
                    "选择 否， 不导入，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
                Cbo序号导入 = Null
                Txt空白.SetFocus
                Exit Sub
            End If
        Else
            Cbo序号导入 = Null
            Txt空白.SetFocus
            Exit Sub
        End If
    Else
            MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
            Txt空白.SetFocus
            Exit Sub
    End If
                DoCmd.SetWarnings False  '关闭系统消息
    Select Case Cbo序号导入
        Case "序号导入 9"
            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT tbl自然.序号 FROM tbl自然 WHERE (((tbl自然.序号) Between 1 And 9)) ORDER BY tbl自然.序号"
        Case "序号导入 99"
            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT tbl自然.序号 FROM tbl自然 WHERE (((tbl自然.序号) Between 1 And 99)) ORDER BY tbl自然.序号"
        Case "序号导入 999"
            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT tbl自然.序号 FROM tbl自然 WHERE (((tbl自然.序号) Between 1 And 999)) ORDER BY tbl自然.序号"
        Case "序号导入 9999"
            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT tbl自然.序号 FROM tbl自然 WHERE (((tbl自然.序号) Between 1 And 9999)) ORDER BY tbl自然.序号"
        Case "序号导入 99999"
            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT tbl自然.序号 FROM tbl自然 WHERE (((tbl自然.序号) Between 1 And 99999)) ORDER BY tbl自然.序号"
        Case "序号导入 999999"
            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT tbl自然.序号 FROM tbl自然 WHERE (((tbl自然.序号) Between 1 And 999999)) ORDER BY tbl自然.序号"
        Case Else
            MsgBox "请在列表中选择！", vbInformation, "温馨提示"
            Cbo序号导入 = Null
                DoCmd.SetWarnings True   '打开系统消息
            Txt空白.SetFocus
            Exit Sub
    End Select
                DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "序号导入 完成操作！", vbInformation, "温馨提示"
        Cbo序号导入 = Null
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
        Resume ErrorHandlerExit
End Sub

Private Sub Cbo序号导入_GotFocus()
On Error GoTo ErrorHandler
        Cbo序号导入.Dropdown
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.编码 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "编码清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.编码 = Null"
        Me.Requery
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.编码 = Format([序号],'000000')"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "编码添加 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.累加 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "累加清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
        Rem 符合条件，继续运行！
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Dim intMsg As Integer
        intMsg = MsgBox("程序将要" & vbCrLf & _
                        "依据序号，添加累加！" & vbCrLf & vbCrLf & _
                        "是否 添加累加？" & vbCrLf & vbCrLf & _
                        "选择 是， 添加。（默认）" & vbCrLf & _
                        "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示")
    If intMsg = vbNo Then
        Txt空白.SetFocus
        Exit Sub
    End If
        Dim i As Long, X As Long, Y As Long, Z As Long
        Dim dblDouble As Double
        Dim strString As String
            X = DMin("[序号]", "tbl号码")
            Y = DMax("[序号]", "tbl号码")
            Z = Y - X + 1
    If lngCount = Z Then
        If MsgBox("程序将要运用" & vbCrLf & _
                "更新查询 等差数列求和公式 的方法取值！" & vbCrLf & _
                "用时很短 一步到位 简捷高效！" & vbCrLf & vbCrLf & _
                "是否 继续添加累加？" & vbCrLf & vbCrLf & _
                "选择 是， 添加。（默认）" & vbCrLf & _
                "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.累加 = Null"
        Me.Requery
            strString = "([序号] + " & X & ") / 2 * ([序号] - " & X & " + 1)"
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.累加 = " & strString
            DoCmd.SetWarnings True   '打开系统消息
    Else
        If MsgBox("程序将要采取 按升序逐个相加 的方法取值！" & vbCrLf & _
                "特别适合 跳号缺号断号 的无规律数列情况！" & vbCrLf & _
                "用时较长 需要耐心等待 不宜施加其它操作！" & vbCrLf & vbCrLf & _
                "是否 继续添加累加？" & vbCrLf & vbCrLf & _
                "选择 是， 添加。（默认）" & vbCrLf & _
                "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.累加 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
            Dim daoRst As Recordset
            Set daoRst = Me.RecordsetClone
        For i = X To Y
                daoRst.FindFirst "序号 = " & Str(Nz(X, 0))
            If Not daoRst.NoMatch Then
                Me.Bookmark = daoRst.Bookmark
                dblDouble = dblDouble + X
                累加 = dblDouble
            End If
                X = X + 1
        Next i
    End If
        Me.Requery
        MsgBox "累加添加 完成操作！", vbInformation, "温馨提示"
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
    If Err.Number = 6 Then
        MsgBox "数据溢出了！", vbExclamation, "郑重提示"
        Me.Requery
    Else
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    End If
        Resume ErrorHandlerExit
End Sub

Private Sub Cmd阶乘清空_Click()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.阶乘 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "阶乘清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
        Rem 符合条件，继续运行！
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.阶乘 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        Dim i As Long, X As Long, Y As Long
        Dim dblDouble As Double
            dblDouble = 1
            X = DMin("[序号]", "tbl号码")
            Y = DMax("[序号]", "tbl号码")
            Dim daoRst As Recordset
            Set daoRst = Me.RecordsetClone
        For i = X To Y
                daoRst.FindFirst "序号 = " & Str(Nz(X, 0))
            If Not daoRst.NoMatch Then
                Me.Bookmark = daoRst.Bookmark
                dblDouble = dblDouble * X
                If X = 0 Then dblDouble = 1
                阶乘 = dblDouble
            End If
                X = X + 1
        Next i
        Me.Requery
        MsgBox "阶乘添加 完成操作！", vbInformation, "温馨提示"
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
    If Err.Number = 6 Then
        MsgBox "当 序号=" & X & " 时，阶乘添加 数据溢出了！", vbExclamation, "郑重提示"
        Me.Requery
    Else
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    End If
        Resume ErrorHandlerExit
End Sub

Private Sub Cmd平方清空_Click()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.平方 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "平方清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.平方 = Null"
        Me.Requery
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.平方 = [序号]^2"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "平方添加 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
    If Err.Number = 6 Then
        MsgBox "数据溢出了！", vbExclamation, "郑重提示"
        Me.Requery
    Else
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    End If
        Resume ErrorHandlerExit
End Sub

Private Sub cmd平方和清空_Click()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.平方和 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "平方和清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
        Rem 符合条件，继续运行！
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Dim intMsg As Integer
        intMsg = MsgBox("程序将要" & vbCrLf & _
                        "依据序号，添加平方和！" & vbCrLf & vbCrLf & _
                        "是否 添加平方和？" & vbCrLf & vbCrLf & _
                        "选择 是， 添加。（默认）" & vbCrLf & _
                        "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示")
    If intMsg = vbNo Then
        Txt空白.SetFocus
        Exit Sub
    End If
        Dim i As Long, X As Long, Y As Long, Z As Long, W As Long
        Dim dblW As Double
        Dim dblDouble As Double
        Dim strString As String
            X = DMin("[序号]", "tbl号码")
            Y = DMax("[序号]", "tbl号码")
            Z = Y - X + 1
            W = X - 1
            dblW = W * (W + 1) * (2 * W + 1) / 6
    If lngCount = Z Then
        If MsgBox("程序将要运用" & vbCrLf & _
                "更新查询 平方和数列求和公式 的方法取值！" & vbCrLf & _
                "用时很短 一步到位 简捷高效！" & vbCrLf & vbCrLf & _
                "是否 继续添加平方和？" & vbCrLf & vbCrLf & _
                "选择 是， 添加。（默认）" & vbCrLf & _
                "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.平方和 = Null"
        Me.Requery
        If X >= 0 And X <= 1 Then
            strString = "UPDATE tbl号码 SET tbl号码.平方和 = [序号] * ([序号] + 1) * (2 * [序号] + 1) / 6"
        ElseIf X > 1 Then
            strString = "UPDATE tbl号码 SET tbl号码.平方和 = [序号] * ([序号] + 1) * (2 * [序号] + 1) / 6 - " & dblW
        Else
            MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
            DoCmd.SetWarnings True   '打开系统消息
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.RunSQL strString
            DoCmd.SetWarnings True   '打开系统消息
    Else
        If MsgBox("程序将要采取 按升序逐个相加 的方法取值！" & vbCrLf & _
                "特别适合 跳号缺号断号 的无规律数列情况！" & vbCrLf & _
                "用时较长 需要耐心等待 不宜施加其它操作！" & vbCrLf & vbCrLf & _
                "是否 继续添加平方和？" & vbCrLf & vbCrLf & _
                "选择 是， 添加。（默认）" & vbCrLf & _
                "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.平方和 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
            Dim daoRst As Recordset
            Set daoRst = Me.RecordsetClone
        For i = X To Y
                daoRst.FindFirst "序号 = " & Str(Nz(X, 0))
            If Not daoRst.NoMatch Then
                Me.Bookmark = daoRst.Bookmark
                dblDouble = dblDouble + X ^ 2
                平方和 = dblDouble
            End If
                X = X + 1
        Next i
    End If
        Me.Requery
        MsgBox "平方和添加 完成操作！", vbInformation, "温馨提示"
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
    If Err.Number = 6 Then
        MsgBox "数据溢出了！", vbExclamation, "郑重提示"
        Me.Requery
    Else
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    End If
        Resume ErrorHandlerExit
End Sub

Private Sub Cmd立方清空_Click()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.立方 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "立方清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.立方 = Null"
        Me.Requery
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.立方 = [序号]^3"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "立方添加 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
    If Err.Number = 6 Then
        MsgBox "数据溢出了！", vbExclamation, "郑重提示"
        Me.Requery
    Else
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    End If
        Resume ErrorHandlerExit
End Sub

Private Sub cmd立方和清空_Click()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.立方和 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
        MsgBox "立方和清空 完成操作！", vbInformation, "温馨提示"
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Txt空白.SetFocus
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.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        MsgBox "表中 尚无记录呢！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        Exit Sub
    ElseIf lngCount > 0 Then
        Rem 符合条件，继续运行！
    Else
        MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
        Txt空白.SetFocus
        Exit Sub
    End If
        Dim intMsg As Integer
        intMsg = MsgBox("程序将要" & vbCrLf & _
                        "依据序号，添加立方和！" & vbCrLf & vbCrLf & _
                        "是否 添加立方和？" & vbCrLf & vbCrLf & _
                        "选择 是， 添加。（默认）" & vbCrLf & _
                        "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示")
    If intMsg = vbNo Then
        Txt空白.SetFocus
        Exit Sub
    End If
        Dim i As Long, X As Long, Y As Long, Z As Long, W As Long
        Dim dblW As Double
        Dim dblDouble As Double
        Dim strString As String
            X = DMin("[序号]", "tbl号码")
            Y = DMax("[序号]", "tbl号码")
            Z = Y - X + 1
            W = X - 1
            dblW = W ^ 2 * (W + 1) ^ 2 / 4
    If lngCount = Z Then
        If MsgBox("程序将要运用" & vbCrLf & _
                "更新查询 立方和数列求和公式 的方法取值！" & vbCrLf & _
                "用时很短 一步到位 简捷高效！" & vbCrLf & vbCrLf & _
                "是否 继续添加立方和？" & vbCrLf & vbCrLf & _
                "选择 是， 添加。（默认）" & vbCrLf & _
                "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.立方和 = Null"
        Me.Requery
        If X >= 0 And X <= 1 Then
            strString = "UPDATE tbl号码 SET tbl号码.立方和 = [序号] ^ 2 * ([序号] + 1) ^ 2 / 4"
        ElseIf X > 1 Then
            strString = "UPDATE tbl号码 SET tbl号码.立方和 = [序号] ^ 2 * ([序号] + 1) ^ 2 / 4 - " & dblW
        Else
            MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
            DoCmd.SetWarnings True   '打开系统消息
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.RunSQL strString
            DoCmd.SetWarnings True   '打开系统消息
    Else
        If MsgBox("程序将要采取 按升序逐个相加 的方法取值！" & vbCrLf & _
                "特别适合 跳号缺号断号 的无规律数列情况！" & vbCrLf & _
                "用时较长 需要耐心等待 不宜施加其它操作！" & vbCrLf & vbCrLf & _
                "是否 继续添加立方和？" & vbCrLf & vbCrLf & _
                "选择 是， 添加。（默认）" & vbCrLf & _
                "选择 否， 不添加，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
            Txt空白.SetFocus
            Exit Sub
        End If
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "UPDATE tbl号码 SET tbl号码.立方和 = Null"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Requery
            Dim daoRst As Recordset
            Set daoRst = Me.RecordsetClone
        For i = X To Y
                daoRst.FindFirst "序号 = " & Str(Nz(X, 0))
            If Not daoRst.NoMatch Then
                Me.Bookmark = daoRst.Bookmark
                dblDouble = dblDouble + X ^ 3
                立方和 = dblDouble
            End If
                X = X + 1
        Next i
    End If
        Me.Requery
        MsgBox "立方和添加 完成操作！", vbInformation, "温馨提示"
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
    If Err.Number = 6 Then
        MsgBox "数据溢出了！", vbExclamation, "郑重提示"
        Me.Requery
    Else
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
    End If
        Resume ErrorHandlerExit
End Sub

Private Sub Cbo序号创建_AfterUpdate()
On Error GoTo ErrorHandler
        DoCmd.Close acTable, "tbl号码"
        DoCmd.Close acQuery, "qry号码"
        Me.Requery
    Dim lngCount As Long
        lngCount = DCount("序号", "tbl号码")
    If lngCount = 0 Then
        Dim intMsg As Integer
            intMsg = MsgBox("表中 尚无记录呢！" & vbCrLf & vbCrLf & _
                            "是否 创建序号？" & vbCrLf & vbCrLf & _
                            "选择 是， 创建。（默认）" & vbCrLf & _
                            "选择 否， 不创建，退出。", vbYesNo + vbInformation, "温馨提示")
        If intMsg = vbNo Then
            Cbo序号创建 = Null
            Txt空白.SetFocus
            Exit Sub
        End If
    ElseIf lngCount > 0 Then
        Dim prompt As String, Title As String, Result As Integer
            prompt = prompt & "表中 尚有记录呢！" & vbCrLf
            prompt = prompt & "应该 先删除 再创建！" & vbCrLf & vbCrLf
            prompt = prompt & "是否 删除 表中 全部记录？" & vbCrLf & vbCrLf
            prompt = prompt & "选择 是， 删除。（默认）" & vbCrLf
            prompt = prompt & "选择 否， 不删除，退出。"
            Title = "温馨提示"
            Result = MsgBox(prompt, vbYesNo + vbInformation, Title)
        If Result = vbYes Then
                DoCmd.SetWarnings False  '关闭系统消息
            DoCmd.RunSQL "DELETE tbl号码.* FROM tbl号码"
                DoCmd.SetWarnings True   '打开系统消息
            Me.Requery
            If MsgBox("已经删除 全部记录！" & vbCrLf & vbCrLf & _
                    "是否 创建序号？" & vbCrLf & vbCrLf & _
                    "选择 是， 创建。（默认）" & vbCrLf & _
                    "选择 否， 不创建，退出。", vbYesNo + vbInformation, "温馨提示") = vbNo Then
                Cbo序号创建 = Null
                Txt空白.SetFocus
                Exit Sub
            End If
        Else
            Cbo序号创建 = Null
            Txt空白.SetFocus
            Exit Sub
        End If
    Else
            MsgBox "代码设计 存在缺陷啊！直接退出！", vbExclamation, "郑重提示"
            Txt空白.SetFocus
            Exit Sub
    End If
    
            Txt开始时间 = Null
            Txt结束时间 = Null
            Txt运行时间 = Null
            
       Dim dtmKaiShi As Date
            dtmKaiShi = Time
            Txt开始时间 = dtmKaiShi
            Me.Requery
            
                Rem 如果 运行 Select Case --- End 语句，
                Rem 那么 Txt开始时间 = dtmKaiShi 就不能即时显示，
                Rem 所以 必须运行 Me.Requery！
                Rem 为何出现这种情况，尚不明了。
                
            DoCmd.SetWarnings False  '关闭系统消息
    Select Case Cbo序号创建
        Case "序号创建 9"
            Call fun序号创建9
        Case "序号创建 99"
            Call fun序号创建99
        Case "序号创建 999"
            Call fun序号创建999
        Case "序号创建 9999"
            Call fun序号创建9999
        Case "序号创建 99999"
            Call fun序号创建99999
        Case "序号创建 999999"
            Call fun序号创建999999
        Case Else
            DoCmd.SetWarnings True   '打开系统消息
            MsgBox "请在列表中选择！", vbInformation, "温馨提示"
            Cbo序号创建 = Null
            Txt开始时间 = Null
            Txt空白.SetFocus
            Exit Sub
    End Select
            DoCmd.RunSQL "DELETE tbl号码.*, 序号 FROM tbl号码 WHERE 序号=0"
            DoCmd.SetWarnings True   '打开系统消息
            Me.Requery
            
        Dim dtmJieShu As Date
            dtmJieShu = Time
            Txt结束时间 = dtmJieShu
            
        Dim dtmYunXing As Date
    If dtmJieShu >= dtmKaiShi Then
        dtmYunXing = TimeValue(dtmJieShu) - TimeValue(dtmKaiShi)
    Else
        dtmYunXing = TimeValue("23:59:59") - TimeValue(dtmKaiShi) + TimeValue("0:00:01") + TimeValue(dtmJieShu)
    End If
            Txt运行时间 = dtmYunXing
            
    If Cbo序号创建 = "序号创建 9999" Then
        Lab四九.Caption = "  序号创建 9999   用时 " & dtmYunXing
    ElseIf Cbo序号创建 = "序号创建 99999" Then
        Lab五九.Caption = "  序号创建 99999  用时 " & dtmYunXing
    ElseIf Cbo序号创建 = "序号创建 999999" Then
        Lab六九.Caption = "  序号创建 999999 用时 " & dtmYunXing
    Else
        Rem 忽略跳过，继续运行！
    End If
    
            DoCmd.SetWarnings False  '关闭系统消息
        DoCmd.RunSQL "INSERT INTO tbl时间 ( 名称, 开始, 结束, 运行 ) SELECT Cbo序号创建, Txt开始时间, Txt结束时间, Txt运行时间"
            DoCmd.SetWarnings True   '打开系统消息
        Me.Chd用时子窗体.Requery
        
        MsgBox "序号创建 完成操作！", vbInformation, "温馨提示"
        Txt空白.SetFocus
        
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
        Cbo序号创建 = Null
        Txt开始时间 = Null
        Txt结束时间 = Null
        Txt运行时间 = Null
        Txt空白.SetFocus
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
        Resume ErrorHandlerExit
End Sub

Private Sub Cbo序号创建_GotFocus()
On Error GoTo ErrorHandler
        Cbo序号创建.Dropdown
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
        Resume ErrorHandlerExit
End Sub

Private Function fun序号创建9()
            Dim A As Integer, lngLong As Long
                    For A = 0 To 9
                        lngLong = A
                        'If lngLong <> 0 Then
                            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT " & lngLong
                        'End If
                    Next A
End Function

Private Function fun序号创建99()
            Dim A As Integer, B As Integer, lngLong As Long
                For B = 0 To 9
                    For A = 0 To 9
                        lngLong = B & A
                        'If lngLong <> 0 Then
                            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT " & lngLong
                        'End If
                    Next A
                Next B
End Function

Private Function fun序号创建999()
            Dim A As Integer, B As Integer, C As Integer, lngLong As Long
            For C = 0 To 9
                For B = 0 To 9
                    For A = 0 To 9
                        lngLong = C & B & A
                        'If lngLong <> 0 Then
                            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT " & lngLong
                        'End If
                    Next A
                Next B
            Next C
End Function

Private Function fun序号创建9999()
            Dim A As Integer, B As Integer, C As Integer, D As Integer, lngLong As Long
        For D = 0 To 9
            For C = 0 To 9
                For B = 0 To 9
                    For A = 0 To 9
                        lngLong = D & C & B & A
                        'If lngLong <> 0 Then
                            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT " & lngLong
                        'End If
                    Next A
                Next B
            Next C
        Next D
End Function

Private Function fun序号创建99999()
            Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, lngLong As Long
    For E = 0 To 9
        For D = 0 To 9
            For C = 0 To 9
                For B = 0 To 9
                    For A = 0 To 9
                        lngLong = E & D & C & B & A
                        'If lngLong <> 0 Then
                            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT " & lngLong
                        'End If
                    Next A
                Next B
            Next C
        Next D
    Next E
End Function

Private Function fun序号创建999999()
            Dim A As Integer, B As Integer, C As Integer, D As Integer, E As Integer, F As Integer, lngLong As Long
For F = 0 To 9
    For E = 0 To 9
        For D = 0 To 9
            For C = 0 To 9
                For B = 0 To 9
                    For A = 0 To 9
                        lngLong = F & E & D & C & B & A
                        'If lngLong <> 0 Then
                            DoCmd.RunSQL "INSERT INTO tbl号码 ( 序号 ) SELECT " & lngLong
                        'End If
                    Next A
                Next B
            Next C
        Next D
    Next E
Next F
End Function

Private Sub qry号码_Click()
On Error GoTo ErrorHandler
        Txt空白.SetFocus
        DoCmd.Close acQuery, "qry号码"
        DoCmd.OpenQuery "qry号码"
ErrorHandlerExit:
        Exit Sub
ErrorHandler:
        MsgBox "Error No：" & Err.Number & Space(4) & "Description：" & Err.Description
        Resume ErrorHandlerExit
End Sub

Private Sub qry时间_Click()
On Error GoTo ErrorHandler
        Txt空白.SetFocus
        DoCmd.Close acQuery, "qry时间"
        DoCmd.OpenQuery "qry时间"
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
        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源码网店