module1.bas

实现M5加密算法的源程序

Attribute VB_Name = "Normal"
Option Explicit
Global Start As Long
Global Const lng As Long = 2147483647
Global Const freq As Double = 1193180
Global Const PI As Double = 3.14159265358979
Global Const PI2  As Double = PI + PI
Global Const DataPath As String = "E:\范翔\素材\data"
Global Const DataPath1 As String = "E:\范翔\素材\QieBi9"
Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type

Function GetTime() As Long
Dim result As LARGE_INTEGER
Dim a As Long
a = QueryPerformanceCounter(result)
GetTime = result.lowpart
End Function

Sub FillArray(Rows As Integer, Cols As Integer, a() As Double, ParamArray Data())
Dim i As Integer, j As Integer, z As Integer
If Rows = 1 Then
    For i = 1 To Cols
        a(i) = Data(i - 1)
    Next i
    Exit Sub
End If
For i = 1 To Rows
    For j = 1 To Cols
        a(i, j) = Data(z)
        z = z + 1
    Next j
Next i
End Sub

Sub FillArraySpe(Rows As Integer, Cols As Integer, a() As Long, ParamArray Data())
Dim i As Integer, j As Integer, z As Integer
If Rows = 1 Then
    For i = 1 To Cols
        a(i) = Data(i - 1)
    Next i
    Exit Sub
End If
For i = 1 To Rows
    For j = 1 To Cols
        a(i, j) = Data(z)
        z = z + 1
    Next j
Next i
End Sub

Function OutPutArray(x() As Double, n As Integer) As String
Dim i As Integer
Dim res As String
res = x(1)
For i = 2 To n
    res = res & "," & x(i)
Next i
OutPutArray = res
End Function

Function gjue(ByVal a, b)
Dim c As Long
    Do
    a = a Mod b
    c = b
    b = a
    a = c
    Loop Until b = 0
gjue = a
End Function

Function modd(ByVal b, ByVal p, k) As Long
Dim l, i As Integer
Dim a(16) As Byte
Dim r As Long
Do Until p = 0
    l = l + 1
    a(l) = p Mod 2
    p = p \ 2
Loop
b = b Mod k: r = b
For i = l - 1 To 1 Step -1
    If r > k / 2 Then r = k - r
    r = r * r Mod k
    If a(i) = 1 Then r = b * r Mod k
Next i
modd = r
End Function

Sub ToSqr(n As Long)
Dim a As Long, b As Long, c As Long, q As Long, k As Long
a = Int(Sqr(n)): b = a: c = n - a * a: q = a
Do
    a = (q + b) \ c
    b = c * a - b
    k = (n - b * b) \ c
    If k = c Then Maths.tval = n & "=" & k & "^2+" & b & "^2"
    c = k
Loop Until c = 1
End Sub

Function Prime(n As Long) As Boolean
Dim d As Long, i As Long
    If n = 2 Or n = 3 Then Prime = True: Exit Function
    If (n Mod 2 = 0) Or (n Mod 3 = 0) Then Exit Function
    For i = 5 To Sqr(n + 0.5) Step 2
        If (n Mod i) = 0 Then Exit Function
        d = i + 2
        If (n Mod d) = 0 Then Exit Function
    Next i
    Prime = True
End Function

Function PrimeSpe(n As Long) As Boolean
Dim d As Long, i As Long
    For i = 5 To Sqr(n + 0.5) Step 2
        If (n Mod i) = 0 Then
             PrimeSpe = False
             Exit Function
        End If
        d = i + 2
        If (n Mod d) = 0 Then
             PrimeSpe = False
             Exit Function
        End If
    Next i
    PrimeSpe = True
End Function

Sub Field(a() As Byte, n As Long)
Dim i As Long, j As Long, d As Long, g As Long
g = Int(Sqr(n + 0.5))
For i = 5 To Sqr(n + 0.5) Step 6
    If a(i) = 0 Then
        For j = i * i To n Step i + i
            a(j) = 1
        Next j
    End If
    d = i + 2
    If d <= g Then
        If a(d) = 0 Then
            For j = d * d To n Step d + d
                a(j) = 1
            Next j
        End If
    End If
Next i
End Sub

'求一定范围内素数
Sub FieldA(a() As Byte, low As Long, high As Long)
Dim p As Long, i As Long, q As Long, j As Long, k As Long
Dim b() As Byte
p = Int(Sqr(high + 0.5))
ReDim b(p)
Field b(), p
For i = 5 To p Step 6
    If b(i) = 0 Then
        q = low \ i: q = q + (q Mod 2) + 1
        If q < i Then q = i
        For j = q * i To high Step i + i
            a(j) = 1
        Next j
    End If
    k = i + 2
    If k <= high Then
        If b(k) = 0 Then
        q = low \ k: q = q + (q Mod 2) + 1
        If q < k Then q = k
            For j = q * k To high Step k + k
                a(j) = 1
            Next j
        End If
    End If
Next i
End Sub

'素数表达式
Function PrimePoly(a() As Byte, n As Long) As Boolean
PrimePoly = a(n) + a(n + 2) + a(n + 6) + a(n + 12) + a(n + 20) + a(n + 30) + a(n + 42) + a(n + 56) + a(n + 72)  '+ a(n + 90) + a(n + 110)
End Function

'偶Goldbach猜想
Function Goldbach(n As Long) As Long
Dim a As Integer, t As Long, m As Long, c As Long, i As Long
If n Mod 2 <> 0 Then Exit Function
If n = 6 Then Goldbach = 1: Exit Function
a = n Mod 6
If a <> 0 Then
    If Prime(n - 3) Then t = 1
End If
m = n / 2
With Maths
Select Case a
    Case 4
        For i = 5 To m Step 6
            If PrimeSpe(i) Then
                If PrimeSpe(n - i) Then t = t + 1 ': .tval.Text = .tval.Text & i & "+" & n - i & vbcrlf
            End If
        Next i
    Case 2
        For i = 7 To m Step 6
            If PrimeSpe(i) Then
                If PrimeSpe(n - i) Then t = t + 1 ': .tval = .tval & i & "+" & n - i & vbcrlf
            End If
        Next i
    Case 0
        For i = 5 To m Step 6
            If PrimeSpe(i) Then
                If PrimeSpe(n - i) Then t = t + 1 ': .tval = .tval & i & "+" & n - i & vbcrlf
            End If
            c = i + 2
            If c < m Then
                If PrimeSpe(c) Then
                    If PrimeSpe(n - c) Then t = t + 1 ': .tval = .tval & c & "+" & n - c & vbcrlf
                End If
            End If
        Next i
End Select
End With
Goldbach = t
End Function

'按"取消"返回-1;否则返回数字
Function ask(a As String, b As String, p As Long) As Long
Dim n As Variant
n = InputBox(a, b)
Do
If n = "" Then ask = -1: Exit Function
If IsNumeric(n) Then
    If n < p And n > 0 And InStr(n, ".") = 0 Then
    ask = n: Exit Function
    Else
        If n >= p Then
            MsgBox "输入数应小于" & p, vbCritical
        Else
            MsgBox "请输入正整数", vbCritical
        End If
    End If
Else
    MsgBox "请输入数字", vbCritical
End If
n = InputBox(a, b)
Loop While True
End Function

Function ThreePlus(a() As Integer, n As Integer, Steps As Integer) As Boolean
Dim i As Integer
Do
    If a(1) Mod 2 = 0 Then
        DivideTwo a(), n
        i = i + 1
        If (n = 1 And a(1) = 1) Then Exit Do
    Else
        MultiplyT a(), n
        i = i + 1
        If n = 32767 Then i = 32767: Exit Do
    End If
Loop Until i = 32767
If i <> 32767 Then Steps = i: ThreePlus = True
End Function
Sub DivideTwo(a() As Integer, n As Integer)
Dim i As Integer
For i = n To 1 Step -1
    If a(i) Mod 2 = 1 Then
        a(i - 1) = a(i - 1) + 10
        a(i) = a(i) - 1
    End If
    a(i) = a(i) / 2
Next i
If a(n) = 0 Then n = n - 1
End Sub
Sub MultiplyT(a() As Integer, n As Integer)
Dim i As Integer, e As Integer
a(1) = a(1) * 3 + 1
e = a(1) \ 10: a(1) = a(1) Mod 10
For i = 2 To n
    a(i) = a(i) * 3 + e
    e = a(i) \ 10
    a(i) = a(i) Mod 10
Next i
If e Then n = n + 1: a(n) = e
End Sub

Function ThreePlusEx(a() As Integer, n As Integer, Steps As Integer) As Boolean
Dim k As Integer, t As Integer, max As Integer, s As Integer, e As Integer, i As Integer, j As Integer, m As Integer
On Error GoTo err
max = n
Do
    k = 1
    Do While a(k) = 0
        k = k + 1
    Loop
    t = t + k - 1: max = max - k + 1
    If max = 1 Then ThreePlusEx = True: Steps = t: Exit Function
    e = 0: i = 2: s = a(k) + 1
    If s = 2 Then s = 0: e = 1
    m = a(k)
    a(1) = s
    For j = k + 1 To k + max - 1
        s = a(j) + m + e
        m = a(j)
        If s > 1 Then
            s = s - 2: e = 1
        Else
            e = 0
        End If
        a(i) = s
        i = i + 1
    Next j
    s = e + m
    If s = 1 Then
        max = max + 1: a(max) = 1
    Else
        max = max + 2: a(max - 1) = 0: a(max) = 1
    End If
    t = t + 1
Loop While True
err:
End Function

Function MoneyConvert(num As Long) As String
Dim i As Integer
Dim a(3) As Integer
Dim b(4) As String, c(3) As String
For i = 1 To 3
a(i) = num Mod 10000
b(i) = MoneyThou(a(i))
num = num \ 10000
Next i
If b(3) <> "" Then
    b(3) = b(3) & "亿"
    If b(2) <> "" Then
        b(2) = b(2) & "万"
        If InStr(b(2), "仟") = 0 Then b(2) = "零" & b(2)
        If InStr(b(1), "仟") = 0 And b(1) <> "" Then b(1) = "零" & b(1)
    Else
        If b(1) <> "" Then b(2) = b(2) & "零"
    End If
Else
    If b(2) <> "" Then
        b(2) = b(2) & "万"
        If InStr(b(1), "仟") = 0 And b(1) <> "" Then b(2) = b(2) & "零"
    End If
End If
MoneyConvert = b(3) & b(2) & b(1)
If MoneyConvert = "" Then MoneyConvert = "零"
End Function

Function MoneyThou(ByVal num As Integer) As String
Dim a(4) As Integer
Dim i As Integer
Dim b(5) As String
Dim c(4) As String
c(2) = "拾"
c(3) = "佰"
c(4) = "仟"
For i = 1 To 4
a(i) = num Mod 10
b(i) = Money(a(i))
num = num \ 10
Next i
MoneyThou = Money(a(1))
For i = 2 To 4
If b(i) = "" Then
    If b(i + 1) <> "" Then b(i) = "零"
Else
    If i = 2 And b(i) = "壹" Then
        b(i) = c(i)
    Else
        b(i) = b(i) & c(i)
    End If
End If
MoneyThou = b(i) & MoneyThou
Next i
End Function

Function Money(num As Integer) As String
Dim a As String
Select Case num
    Case 0
        a = ""
    Case 1
        a = "壹"
    Case 2
        a = "贰"
    Case 3
        a = "叁"
    Case 4
        a = "肆"
    Case 5
        a = "伍"
    Case 6
        a = "陆"
    Case 7
        a = "柒"
    Case 8
        a = "捌"
    Case 9
        a = "玖"
End Select
Money = a
End Function

'HCode()不应初始化
Sub ConvertToString(Data() As Long, Length As Long, DisString As String, num As Long, HCode() As Byte)
Dim i As Byte, HexVal(9) As Byte, dis() As Byte
Dim ln As Long, DisLength As Long
Dim j As Long, z As Long, temp As Long, Pos As Long
For i = 0 To 9
    HexVal(i) = 48 + i
Next i
ln = Len(CStr(Data(num)))
DisLength = LenB(DisString)
ln = Length * (num - 1) + ln
ReDim HCode(ln + ln + DisLength - 1)
Pos = ln + ln - 2 + DisLength
For j = 1 To num - 1
    temp = Data(j)
    For z = 1 To Length
        HCode(Pos) = HexVal(temp Mod 10)
        temp = temp \ 10
        Pos = Pos - 2
    Next z
Next j
temp = Data(num)
Do Until temp = 0
    HCode(Pos) = HexVal(temp Mod 10)
    temp = temp \ 10
    Pos = Pos - 2
Loop
ReDim dis(DisLength)
dis = DisString
For i = 0 To DisLength - 1
    HCode(i) = dis(i)
Next i
Erase dis
End Sub