frmmain.frm

计算1!+2!+3!+...+n!的较快的算法。

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form frmMain 
   Caption         =   "求阶乘之和 最终版 by multiple1902"
   ClientHeight    =   4170
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   8715
   LinkTopic       =   "Form1"
   ScaleHeight     =   4170
   ScaleWidth      =   8715
   StartUpPosition =   2  'CenterScreen
   Begin RichTextLib.RichTextBox txtOutput 
      Height          =   3495
      Left            =   120
      TabIndex        =   4
      Top             =   600
      Width           =   8415
      _ExtentX        =   14843
      _ExtentY        =   6165
      _Version        =   393217
      Enabled         =   -1  'True
      ScrollBars      =   2
      TextRTF         =   $"frmMain.frx":0000
   End
   Begin VB.CommandButton command_solution_docalc 
      Caption         =   "计算(&S)"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   2520
      TabIndex        =   2
      Top             =   120
      Width           =   855
   End
   Begin VB.TextBox input_problem_n 
      Alignment       =   2  'Center
      Height          =   285
      Left            =   1320
      TabIndex        =   1
      Top             =   120
      Width           =   975
   End
   Begin VB.Label lblFormula 
      Caption         =   "请输入N的取值，这里将显示计算公式"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   3480
      TabIndex        =   3
      Top             =   120
      Width           =   4935
   End
   Begin VB.Label static_effect_discription_1 
      AutoSize        =   -1  'True
      Caption         =   "输入N的值："
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   240
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   1050
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Option Base 1           ' 数组下标从1开始
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

' By multiple1902
' 2007.7.17
' QQ: 395273243



Private Sub command_solution_docalc_Click()
    If Not IsNumeric(input_problem_n.Text) Then
        txtOutput.Text = "输入无效：" & input_problem_n.Text
        Exit Sub
    End If
    
    command_solution_docalc.Enabled = False
    If Val(input_problem_n.Text) > 100 Then
        txtOutput.Text = "正在计算 请稍候"
        DoEvents
    End If
    Dim N As Long   ' 问题中的N
    Dim Sum() As Long   ' 保存总和，高精度。每单元3位
    Dim i As Long, p As Long, top As Long
    Dim time1 As Currency, time2 As Currency, timeold As String
    Dim mcurFreq As Currency, curCounter1 As Currency, curCounter2 As Currency '系统高精度计数器频率

    timeold = Time()
    QueryPerformanceFrequency mcurFreq
    QueryPerformanceCounter curCounter1
    

    
    ReDim Sum(20)
    top = 20
    N = Val(input_problem_n.Text)
    Sum(1) = N Mod 1000
    Sum(2) = N \ 1000
    Sum(3) = N \ 1000000
    p = N - 1
    i = 0
    
    While p >= 1
        If Sum(top) + Sum(top - 1) > 0 Then
            top = Int(top * 1.618 + 1) ' 存储空间不够时增加存储空间
            ReDim Preserve Sum(top)
        End If
        Sum(1) = Sum(1) + 1
        For i = 1 To top
            Sum(i) = Sum(i) * p
        Next
        For i = 1 To top - 1
            If Sum(i) > 999 Then
                Sum(i + 1) = Sum(i + 1) + Sum(i) \ 1000
                Sum(i) = Sum(i) Mod 1000
            End If
        Next
        p = p - 1
    Wend
    If Val(input_problem_n.Text) > 100 Then
        txtOutput.Text = "计算完成 正在输出 请稍等"
        DoEvents
    End If
    
    QueryPerformanceCounter curCounter2  '精确到毫秒
        If mcurFreq <> 0 Then '支持高精度计数
            curCounter2 = (curCounter2 - curCounter1) / mcurFreq
        Else '不支持
            curCounter2 = curCounter2 - curCounter1
        End If


    p = top
    While Sum(p) = 0
        p = p - 1
    Wend
    
    Dim Length As Long, strBuffer As String
    Dim j As Long
    Length = 3 * (p - 1) + Len(Trim(Str(Sum(p))))
    
    Dim oFso As Object, oFile As Object ' 使用FSO输出结果
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Set oFile = oFso.OpenTextFile("Result.txt", 2, 1)
        oFile.write lblFormula.Caption & vbCrLf & "开始时间: " & timeold & vbCrLf & "结束时间: " & Time() _
            & vbCrLf & "总计耗时: " & Format(curCounter2, "#0.0000") & "秒" & vbCrLf _
            & "结果位数: " & Length & vbCrLf & "计算结果: "
        If p > 1 Then oFile.write Sum(p) & ","
        For i = p - 1 To 2 Step -1
            oFile.write String(3 - Len(Trim(Sum(i))), "0") & Sum(i) & ","
        Next
        oFile.write Sum(1)
        oFile.Close
        
    txtOutput.LoadFile "result.txt"
    Kill "result.txt"
    command_solution_docalc.Enabled = True
End Sub

Private Sub Form_Resize()
    Static minX As Currency, minY As Currency
    Static deltaX As Currency, deltaY As Currency
    If (WindowState = 1) Then Exit Sub
    If minX = 0 Then
        minX = Me.Width
        minY = Me.Height
        deltaX = Me.Width - txtOutput.Width
        deltaY = Me.Height - txtOutput.Height
    Else
        If WindowState = 0 Then
           Me.Move Me.Left, Me.top, IIf(Me.Width > minX, Me.Width, minX), IIf(Me.Height > minY, Me.Height, minY)
        End If
        txtOutput.Width = Me.Width - deltaX
        txtOutput.Height = Me.Height - deltaY
    End If
End Sub

Private Sub input_problem_n_Change()
    If Not IsNumeric(input_problem_n.Text) Then
        lblFormula.Caption = "输入无效：" & input_problem_n.Text
        Exit Sub
    End If
    Dim i As Long
    If Val(input_problem_n.Text) > 6 Then
        lblFormula.Caption = "计算公式: 1!+2!+3!+4!+5!+...+" & Val(input_problem_n.Text) & "!"
    Else
        lblFormula.Caption = "计算公式: 1!"
        For i = 2 To Val(input_problem_n)
            lblFormula.Caption = lblFormula.Caption & "+" & i & "!"
        Next
    End If
End Sub

Private Sub txtOutput_DblClick()
    txtOutput = ""
End Sub