frmnumbertheoretic.frm

这是一个应用软件,用于处理大数,里面包含一些小的实用的软件,如生成 素数 ,大数阶乘.

    App.HelpFile = "HugeCalc.chm"
    Me.HelpContextID = HH_HOME
    optRadix(0).HelpContextID = HH_MANUAL
    optRadix(1).HelpContextID = HH_MANUAL
    optCalc(0).HelpContextID = HH_FACTORIAL
    optCalc(1).HelpContextID = HH_FACTORIAL
    optCalc(2).HelpContextID = HH_FACTORIAL
    optCalc(3).HelpContextID = HH_PERMUTATION
    optCalc(4).HelpContextID = HH_COMBINATION
    optCalc(5).HelpContextID = HH_FIBONACCI
    optCalc(6).HelpContextID = HH_LUCAS
    cmdCalc.HelpContextID = HH_MANUAL
    rtbResult.HelpContextID = HH_OUTPUT

    m_nCalcIndex = 0
    m_bHex = False

    L_SetWindowText Me.hWnd, HC_getVer()

    Select Case (HC_getLicenseLevel())
    Case HC_LICENSE_NONE
        Me.Caption = Me.Caption & " ( Unregistered )"
        rtbResult.Text = "警告：您未通过 HugeCalc.dll 的许可认证！" _
                & vbNewLine & vbNewLine & "解决方案可选下列方案之一：" _
            & vbNewLine & vbTab & "一、请移动到文件夹“../CopyrightByGuoXianqiang[/..]/” 下；" _
            & vbNewLine & vbTab & "二、或请在 HugeCalc.chm 中进行注册（一劳永逸）。"

    Case HC_LICENSE_LIMITED
        Me.Caption = Me.Caption & " ( Unregistered )"
        rtbResult.Text = vbNewLine & vbTab & "现在，让我们开始轻松快乐的 VB 高精度快速计算之旅。。。" _
                & vbNewLine & vbNewLine & vbTab & "如果您需要更完善的服务，或支持该产品的持续完善，欢迎您进行注册。。。"

    Case Else   'HC_LICENSE_ALL
        rtbResult.Text = vbNewLine & vbTab & "感谢您对 HugeCalc 的支持！" _
                & vbNewLine & vbNewLine & vbTab & "现在，让我们开始轻松快乐的 VB 高精度快速计算之旅。。。"

    End Select

End Sub

Private Sub optCalc_Click(Index As Integer)
    m_nCalcIndex = Index
    txtR.Enabled = ((3 <= m_nCalcIndex) And (4 >= m_nCalcIndex))
End Sub

Private Sub optRadix_Click(Index As Integer)
    m_bHex = (Index = 1)
    chkOption(4).Enabled = m_bHex
End Sub

Private Sub cmdCalc_Click()
    On Error Resume Next

    Dim hResult As Long
    Dim n As Long, r As Long
    Dim t As Long, nDigits As Long

    Dim nErrCode As Long 'HCErrCode
    Dim strMsg As String, strTip As String, pStr As Variant, nStrLen As Long

    Dim byFormat As Byte

    n = Val(txtN.Text)
    r = Val(txtR.Text)

    If r < 0 Then r = -r
    'fibonacci、lucas 数列下标是可以为负整数的
    If m_nCalcIndex < 5 Then
        If n < 0 Then n = -n
    End If

    txtN.Text = CStr(n)
    txtR.Text = CStr(r)

    txtN.Refresh
    txtR.Refresh


    HC_setTerminate False

    If (False <> HC_isTerminated()) Then
        '对于未注册用户，在解释模式下运行时总是进入该状态；
        '               但运行编译好的程序则会一切正常。
        '这是 VB 本身的问题，与 HugeCalc 无关；特提请注意！
        MsgBox "请按提示处理以获得相关权限。", vbCritical, "HugeCalc 拒绝服务"
        Exit Sub
    End If

    cmdCalc.Enabled = False
    txtN.Locked = True
    txtR.Locked = True

    HC_enableTimer True
    HC_resetTimer 0, TIMER_UNIT_us

    If m_bHex Then

        hResult = HX_new()

        Select Case m_nCalcIndex
        Case 0
            HX_factorial hResult, n

        Case 1
            HX_factorial2 hResult, n

        Case 2
            HX_primeFactorial hResult, n

        Case 3
            HX_permutation hResult, n, r

        Case 4
            HX_combination hResult, n, r

        Case 5
            HX_fibonacci hResult, n

        Case Else
            HX_lucas hResult, n

        End Select

    Else

        hResult = HI_new()

        Select Case m_nCalcIndex
        Case 0
            HI_factorial hResult, n

        Case 1
            HI_factorial2 hResult, n

        Case 2
            HI_primeFactorial hResult, n

        Case 3
            HI_permutation hResult, n, r

        Case 4
            HI_combination hResult, n, r

        Case 5
            HI_fibonacci hResult, n

        Case Else
            HI_lucas hResult, n

        End Select

    End If


    '调用定制好的 WINAPI 将不定长字符串拷贝到 VB 字符串中
    pStr = HC_getTimerStr(FT_DOT06SEC)  '若用 FT_DOT06SEC_s 则无须再补加 “ s”
    nStrLen = L_strlen(pStr)

    strMsg = String$(nStrLen + 1, vbNullChar)
    L_strcpyn strMsg, pStr, nStrLen + 1  '还可调用 L_strcat()、L_strcpy() 等函数

    '下面这行代码的目的是除去 VB 字符串尾多余的 vbNullChar，
    '否则在其尾部再追加的字符将不会被输出!
    '----费了老大的功夫才解了该 bug，幸亏俺还有 C 语言的功底!:)
    strMsg = Left$(strMsg, lstrlen(strMsg))    '第二个参数也可直接用当前 nStrLen 的值.
    '请注意这里 lstrlen() 与 L_strlen() 的区别，尽管它们均由 HugeCalc(U)4VB.tlb 定义

    '如果没有上一行，将不会输出“ s”:(
    labTimer.Caption = "计算耗时：" & strMsg & " s"

    Beep


    If HC_isTerminated() = False Then   'HugeCalc 没有提前终止运算，一切 OK!

        byFormat = 0
        If chkOption(0).Value > vbUnchecked Then byFormat = byFormat + FS_BAND
        If chkOption(1).Value > vbUnchecked Then byFormat = byFormat + FS_BAND_SPACE
        If chkOption(2).Value > vbUnchecked Then byFormat = byFormat + FS_SIGN
        If chkOption(3).Value > vbUnchecked Then byFormat = byFormat + FS_SIGN_SPACE
        If chkOption(4).Value > vbUnchecked Then byFormat = byFormat + FS_CHAR_LOWER

        '计时器复位，准备统计输出耗时
        HC_resetTimer 0, TIMER_UNIT_us

        '调用定制好的 WINAPI 直接将不定长字串写进控件中
        If m_bHex Then
            nDigits = HX_getDigits(hResult)
            pStr = HX_getStr(hResult, byFormat, nStrLen)
        Else
            nDigits = HI_getDigits(hResult)
            pStr = HI_getStr(hResult, byFormat, nStrLen)
        End If

        t = HC_getTimer(TIMER_UNIT_us)
        strTip = "有 " & CStr(nDigits) & " 位（共 " & CStr(nStrLen) & " 个字符）；转换：" & CStr(t) & "微秒"

        '直接写屏，无须额外用一个字符串缓存内容，以提高效率
                L_SetWindowText rtbResult.hWnd, pStr
        strTip = strTip & "；写屏：" & CStr(HC_getTimer(TIMER_UNIT_us) - t) & "微秒"

        Select Case m_nCalcIndex
        Case 0
            strMsg = CStr(n) & "! = "

        Case 1
            strMsg = CStr(n) & "!! = "

        Case 2
            strMsg = "前 " & CStr(n) & " 个素数的连积为（最大素因子=" & CStr(HC_getPrime(n)) & "）：" _
                & vbNewLine & vbTab

        Case 3
            strMsg = "P(" & CStr(n) & "," & CStr(r) & ") = "

        Case 4
            strMsg = "C(" & CStr(n) & "," & CStr(r) & ") = "

        Case 5
            strMsg = "Fibonacci 数列第 " & CStr(n) & " 项为：" & vbNewLine & vbTab

        Case Else
            strMsg = "Lucas 数列第 " & CStr(n) & " 项为：" & vbNewLine & vbTab

        End Select

        With rtbResult
            .SelStart = 0
            .SelLength = 0
            .SelText = strMsg
            .ToolTipText = strTip
        End With

    Else    'HugeCalc 提前终止运算，问题出在哪儿呢？

        nErrCode = HC_getLastError()

        Select Case nErrCode
        Case HCERR_NO_LICENSE
            strTip = "使用许可未通过认证！"

        Case HCERR_USER_STOP
            strTip = "用户终止！"

        Case HCERR_OUTOF_MEM
            strTip = "内存不足!"

        Case HCERR_POINTER_INVALID
            strTip = "指针无效!"

        Case HCERR_DIV_ZERO
            strTip = "除0错误！"

        Case HCERR_BASE2SMALL
            strTip = "底数小于2！"

        Case HCERR_RADIX2SMALL
            strTip = "进制小于2！"

        Case Else
            strTip = "不可知错误！"

        End Select

        rtbResult.Text = vbNewLine & vbTab & strMsg
        rtbResult.ToolTipText = ""

    End If


    '特别注意：new 出的对象最后必须要 delete，否则会有内存泄露！
    If m_bHex Then
        HX_delete hResult
    Else
        HI_delete hResult
    End If

    cmdCalc.Enabled = True
    txtN.Locked = False
    txtR.Locked = False
End Sub