几个vb小程序

ysr

Private Sub Command1_Click()
'验证李明波幂和猜想的程序
Dim a, b
a = Val(Text1)
b = Val(Text2)
a1 = a
Do While a <= b
q = a ^ (1 / 2)
a2 = 2
Do While InStr(Log(a) / Log(a2), ".") > 0 And a2 < q
a2 = a2 + 1
Loop

r = Log(a) / Log(a2)
a3 = a - Int(q) ^ 2
If InStr(r, ".") = 0 Then
Text3 = Text3 & a & "=" & a2 & "^" & r & vbCrLf
ElseIf a3 = 1 Then
Text3 = Text3 & a & "=" & Int(q) & "^" & 2 & "+1" & vbCrLf
ElseIf a3 = 2 Then
Text3 = Text3 & a & "=" & Int(q) & "^" & 2 & "+1+1" & vbCrLf
Else
q1 = Sqr(Val(a3))
a2 = 2
Do While InStr(Log(a3) / Log(a2), ".") > 0 And a2 < q1
a2 = a2 + 1
Loop
r1 = Log(a3) / Log(a2)
a4 = a - Int(q) ^ 2 - Int(q1) ^ 2
If InStr(r1, ".") = 0 Then
Text3 = Text3 & a & "=" & Int(q) & "^2" & "+" & a2 & "^" & r1 & vbCrLf
ElseIf a4 = 1 Then
Text3 = Text3 & a & "=" & Int(q) & "^2" & "+" & Int(q1) & "^" & 2 & "+1" & vbCrLf
Else
q2 = Sqr(Val(a4))
a2 = 2
Do While InStr(Log(a4) / Log(a2), ".") > 0 And a2 < q2
a2 = a2 + 1
Loop
r2 = Log(a4) / Log(a2)
If a4 = 2 Then
js = ksm6(Trim(a), Val(s))
If InStr(js, "+") = 0 Then
s = s + 1
Text3 = Text3 & a & "=无解" & vbCrLf
Else
Text3 = Text3 & js & vbCrLf
End If
ElseIf InStr(r2, ".") = 0 Then
Text3 = Text3 & a & "=" & Int(q) & "^2" & "+" & Int(q1) & "^2+" & a2 & "^" & r2 & vbCrLf

Else

js = ksm6(Trim(a), Val(s))
If InStr(js, "+") = 0 Then
a4 = a - 1
a2 = 2
Do While InStr(Log(a4) / Log(a2), ".") > 0 And a2 < q
a2 = a2 + 1
Loop
r1 = Log(a4) / Log(a2)
If InStr(r1, ".") = 0 Then
Text3 = Text3 & a & "=" & "1+" & a2 & "^" & r1 & vbCrLf
Else
a5 = a - 2
a2 = 2
Do While InStr(Log(a5) / Log(a2), ".") > 0 And a2 < q
a2 = a2 + 1
Loop
r2 = Log(a5) / Log(a2)
If InStr(r2, ".") = 0 Then
Text3 = Text3 & a & "=" & "1+1+" & a2 & "^" & r2 & vbCrLf
Else
ja1 = 2
jc = ksm5(Trim(a), Trim(q))
If InStr(jc, "无解") > 0 Then
js1 = 1
ja = 3
Do While js1 < a ^ (1 / ja)

Do While ja < a ^ (1 / ja)
ax = Abs(a - js1 ^ ja)
js2 = js1 & "^" & ja
jss = ksm7(Val(ax), Trim(js2))
If InStr(jss, "无解") = 0 Then
s1 = s1 + 1
jss1 = jss1 & a & "=" & jss & vbclf
Else
jss1 = jss1 & vbCrLf
End If

ja = ja + 1
Loop


js1 = js1 + 1
Loop
If s1 > 0 Then
Text3 = Text3 & jss1 & vbCrLf
Else
s = s + 1
Text3 = Text3 & a & "=无解" & vbCrLf
End If
Else
Text3 = Text3 & jc & vbCrLf
End If

End If
End If
Else
Text3 = Text3 & js & vbCrLf
End If
End If
End If
End If
a = a + 1
Loop

Combo1 = a1 & "~" & b & "之间，有" & Val(s) & "个无解：" & vbCrLf & Text3


End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""
Text3 = ""
Combo1 = ""

End Sub
Private Function ksm6(sa As String, sb As String) As String '某数的快速幂程序
Dim a, b
a = Val(sa)
s = Val(sb)
a1 = a
ja = 2
b = Int(Log(a) / Log(3))
Do Until ja > b
a3 = a - 3 ^ ja

If a3 = 1 Then
ksm = a & "=" & 3 & "^" & ja & "+1" & "  "
ElseIf a3 = 2 Then
ksm = a & "=" & 3 & "^" & ja & "+1+1" & "  "
Else
q1 = Sqr(Val(a3))
a2 = 2
Do While InStr(Log(a3) / Log(a2), ".") > 0 And a2 < q1
a2 = a2 + 1
Loop
r1 = Log(a3) / Log(a2)
a5 = a2
a4 = a3 - Int(Sqr(a3)) ^ 2
If a4 = 1 Then
ksm = a & "=3^" & ja & "+" & a2 & "^" & Int(r1) & "+1" & "  "
ElseIf InStr(r1, ".") = 0 Then
ksm = a & "=3^" & ja & "+" & a2 & "^" & r1 & "  "

Else
q2 = Sqr(Val(a4))
a2 = 2
Do While InStr(Log(a4) / Log(a2), ".") > 0 And a2 < q2
a2 = a2 + 1
Loop
r2 = Log(a4) / Log(a2)
If Val(r2) = 1 Then
ksm = ksm
ElseIf InStr(r2, ".") = 0 Then
ksm = a & "=3^" & ja & "+" & Int(Sqr(a3)) & "^" & 2 & "+" & a2 & "^" & r2 & "  "
Else

s = s + 1
ksm = a & "=无解" & vbCrLf
End If
End If
End If

If InStr(ksm, "+") > 0 Then
ksm6 = ksm6 & ksm
Else
ksm6 = 无解
End If
ja = ja + 1
Loop

End Function


Private Function ksm7(sa As String, sb As String) As String '某数的快速幂程序
Dim a, q
a = Val(sa)
qr = Trim(sb)
a2 = 2
Do While InStr(Log(a) / Log(a2), ".") > 0 And a2 < a ^ (1 / 2)
a2 = a2 + 1
Loop
r1 = Log(a) / Log(a2)
a4 = a - a2 ^ Int(r1)
If InStr(r1, ".") = 0 Then
s1 = s1 + 1
jss = jss & qr & "+" & a2 & "^" & r1 & vbCrLf
ElseIf a4 = 1 Then
jss = jss & qr & "+" & a2 & "^" & Int(r1) & "+1" & vbCrLf
Else
js1 = 1
ja = 3
Do While js1 < a ^ (1 / ja)

Do While ja < a ^ (1 / ja)
a1 = Abs(a - js1 ^ ja)

If InStr(fenjieyinzi(Val(ja)), "*") = 0 Then
a2 = 2
Do While InStr(Log(a1) / Log(a2), ".") > 0 And a2 < a1 ^ (1 / 2)
a2 = a2 + 1
Loop
r = Log(a1) / Log(a2)
If Val(r) = 0 Then
jss = jss & qr & "+" & js1 & "^" & ja & "+" & "1 " & vbclf
s1 = s1 + 1
ElseIf InStr(r, ".") = 0 Then
s1 = s1 + 1
jss = jss & qr & "+" & js1 & "^" & ja & "+" & a2 & "^" & r & vbclf
Else
jss1 = "无解" & vbCrLf
End If

Else
jss = jss & vbCrLf

End If
ja = ja + 1
Loop


js1 = js1 + 1
Loop
End If
If s1 > 0 Then
ksm7 = jss & vbCrLf
Else
ksm7 = ksm7 & a & "=无解" & vbCrLf
End If
End Function

Private Function paixu1(a As String) As String
Dim i As Integer
Dim ak(), s105, cr(), f
s103 = a
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
   j1 = UBound(s105)
   Print j1
   For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    Print ak(1)
     
        For k = 1 To j1
           
             ReDim Preserve cr(1 To k)
            m = Val(ak(k))
            f(m) = ""
      Next
   
      n = 0
      m = f.Keys
      For i = 0 To f.Count - 1
          ReDim Preserve cr(1 To i + 1)
          cr(i + 1) = m(i)
      Next
     For i = 1 To UBound(cr) - 1
        For j = i + 1 To UBound(cr)
            If cr(i) > cr(j) Then
                temp = cr(j)
                cr(j) = cr(i)
                cr(i) = temp  'c数组是排序好的
            End If
        Next j
        
       ' If i Mod 20 = 0 Then
       ' s104 = s104 & temp & "/" & vbCrLf
       ' Else
       ' s104 = s104 & temp & "/"
       ' End If
    Next i
   
      For i = 1 To UBound(cr)
        If i Mod 20 = 0 Then
          s104 = s104 & cr(i) & "/" & vbCrLf
        Else
          s104 = s104 & cr(i) & "/"
        End If
     Next
         Print temp
         MsgBox "ok"
     MsgBox s104  '显示数组
     paixu1 = s104
End Function

Private Function ksm5(sa As String, sb As String) As String '某数的快速幂程序
Dim a, q
a = Val(sa)
q = Val(sb)
ja1 = 2
Do While ja1 < q
For i = ja1 To Int(q) Step 1
If InStr(ksm4(Trim(a), Val(i)), "+") = 0 Then
ah = False
Exit For

Else: ah = True
js = ksm4(Trim(a), Val(i))
End If
Next

If ah = True Then
s = s + 1
m5 = m5 & a & "=无解" & vbCrLf
Else
If InStr(js, "+") = 0 Then
m5 = m5
Else
s1 = s1 + 1
m5 = m5 & js & vbCrLf
End If
End If
ja1 = ja1 + 1
Loop

If s1 > 0 Then
ksm5 = m5
Else
ksm5 = ksm5 & a & "=无解" & vbCrLf
End If
End Function
Private Function ksm4(sa As String, sb As String) As String '某数的快速幂程序
Dim a, b
a = Val(sa)
ja1 = Val(sb)
a1 = a
ja = 2
b = Int(Log(a) / Log(ja1))
Do Until ja > b
a3 = a - ja1 ^ ja

If a3 = 1 Then
ksm = a & "=" & ja1 & "^" & ja & "+1" & "  "
ElseIf a3 = 2 Then
ksm = a & "=" & ja1 & "^" & ja & "+1+1" & "  "
Else
q1 = Sqr(Val(a3))
a2 = 2
Do While InStr(Log(a3) / Log(a2), ".") > 0 And a2 < q1
a2 = a2 + 1
Loop
r1 = Log(a3) / Log(a2)
a5 = a2
a4 = a3 - Int(Sqr(a3)) ^ 2
If a4 = 1 Then
ksm = a & "=" & ja1 & "^" & ja & "+" & Int(Sqr(a3)) & "^" & 2 & "+1" & "  "
ElseIf InStr(r1, ".") = 0 Then
ksm = a & "=" & ja1 & "^" & ja & "+" & a2 & "^" & r1 & "  "

Else
q2 = Sqr(Val(a4))
a2 = 2
Do While InStr(Log(a4) / Log(a2), ".") > 0 And a2 < q2
a2 = a2 + 1
Loop
r2 = Log(a4) / Log(a2)
If InStr(r2, ".") = 0 And r2 <> 1 Then
ksm = a & "=" & ja1 & "^" & ja & "+" & Int(Sqr(a3)) & "^" & 2 & "+" & a2 & "^" & r2 & "  "
Else

s = s + 1
ksm = a & "=无解"
End If
End If
End If

If InStr(ksm, "无解") > 0 Then
ksm4 = 无解
Else
ksm4 = ksm4 & ksm
End If
ja = ja + 1
Loop

End Function

Private Function fenjieyinzi(sa As String) As String
Dim X, a, b, k As String
a = Val(sa)

X = 3
If a <= 1 Or a > Int(a) Then
If a = 1 Then
fenjieyinzi = "它既不是质数，也不是合数"

Else
MsgBox "error"
End If
  
Else

Do While a / 2 = Int(a / 2) And a >= 4
  
If b = 0 Then
fenjieyinzi = fenjieyinzi & "2"
b = 1
Else
fenjieyinzi = fenjieyinzi & "*2"
End If
a = a / 2
k = a
  
Loop

Do While a > 1
Do While X <= Sqr(a)
Do While a / X = Int(a / X) And a >= X * X
  
If b = 0 Then
fenjieyinzi = fenjieyinzi & X
b = 1
Else
fenjieyinzi = fenjieyinzi & "*" & X
End If
a = a / X
Loop
  
X = X + 2
Loop
  
k = a
a = 1
Loop
  
If b = 1 Then
fenjieyinzi = fenjieyinzi & "*" & k
Else
fenjieyinzi = "这是一个质数"
End If
  
  
  
  

End If

End Function


Private Function paixu11(a3 As String, q As String) As String
a2 = Val(2)
Do While InStr(Val(Log(a3) / Log(a2)), ".") > 0 And a2 <= Val(q)
a2 = Val(a2) + 1
Loop

r = Log(a3) / Log(a2)
paixu11 = a2 & "^" & r
End Function


Private Function paixu(a As String) As String
Dim i As Integer
Dim ak(), s105, cr(), f
s103 = a
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
   j1 = UBound(s105)
   Print j1
   j2 = Val(j1)
   For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    Print ak(1)
     n = 0
        For k = 1 To j1
           For i = 1 To j1
             n = n + 1
             ReDim Preserve cr(1 To n)
            m = Val(ak(k)) + Val(ak(i))
            f(m) = ""
      Next
    Next
      n = 0
      
      m = f.Keys
      For i = 0 To j2
          ReDim Preserve cr(1 To i + 1)
          cr(i + 1) = m(i)
      Next
     For i = 1 To UBound(cr) - 1
        For j = i + 1 To UBound(cr)
            If cr(i) > cr(j) Then
                temp = cr(j)
                cr(j) = cr(i)
                cr(i) = temp  'c数组是排序好的
            End If
        Next j
        
       ' If i Mod 20 = 0 Then
       ' s104 = s104 & temp & "/" & vbCrLf
       ' Else
       ' s104 = s104 & temp & "/"
       ' End If
    Next i
   
      For i = 1 To UBound(cr)
        If i Mod 20 = 0 Then
          s104 = s104 & cr(i) & "/" & vbCrLf
        Else
          s104 = s104 & cr(i) & "/"
        End If
     Next
         Print temp
         MsgBox "ok"
     MsgBox s104  '显示数组
     paixu = s104
End Function

ysr

Private Sub Command1_Click()

'李明波幂和猜想的验证程序，修改一下
Dim a, B, s2, js()
a = Val(1)
B = Val(Text1)
a1 = Val(a)
ja1 = 2
Do While a1 <= B And a1 ^ ja1 <= B

s2 = s2 & "/" & a1 ^ ja1

's3 = s3 & "/" & a1 ^ 3

's5 = s5 & "/" & a1 ^ 5

's6 = s6 & "/" & a1 ^ 7
's7 = s7 & "/" & a1 ^ 11
's8 = s8 & "/" & a1 ^ 13
's9 = s9 & "/" & a1 ^ 17
ja2 = 3
ReDim js(1 To B)
Do While ja2 < B And a1 ^ ja2 <= B

If InStr(fenjieyinzi(Val(ja2)), "*") = 0 Then
js(ja2) = a1 ^ ja2
js1 = js1 & "/" & js(ja2)
Else
js1 = js1
End If
ja2 = ja2 + 1
Loop


a1 = a1 + 1
Loop
Dim ak(), cr()

s10 = js1 & s2 & s5 & s6 & s7 & s8 & s9 & s3

s11 = paixu1(Trim(s10))
s11 = "/" & Mid(s11, 1, Len(s11) - 1)
s11 = paixu(Trim(s11))

a = Val(Text1)
jb = Val(Text1)
ja2 = a
Do While a <= jb
q = a ^ (1 / 2)
a2 = 2
Do While InStr(Log(a) / Log(a2), ".") > 0 And a2 < q
a2 = a2 + 1
Loop

r = Log(a) / Log(a2)
a3 = a - Int(q) ^ 2
If InStr(r, ".") = 0 Then
Text2 = Text2 & a & "=" & a2 & "^" & r & vbCrLf
ElseIf a3 = 1 Then
Text2 = Text2 & a & "=" & Int(q) & "^" & 2 & "+1" & vbCrLf
ElseIf a3 = 2 Then
Text2 = Text2 & a & "=" & Int(q) & "^" & 2 & "+1+1" & vbCrLf
Else
s105 = Split(s11, "/")
j1 = UBound(s105)
For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    k = 1
    Do While k < j1 And Val(a) > Val(ak(k))
    a3 = Abs(Val(a) - Val(ak(k))): a2 = 2: q = Sqr(Val(a3))
    Do While InStr(Log(a3) / Log(a2), ".") > 0 And a2 < q
a2 = Val(a2 + 1)
Loop

r = Log(a3) / Log(a2)
If InStr(r, ".") = 0 Then
Text2 = Text2 & a & "= " & a2 & "^" & r & "+" & Trim(ak(k)) & vbCrLf
Else
a3 = a3
End If
   
    k = Val(k + 1)
    Loop
If InStr(Trim(Text2), "^") = 0 Then
Text2 = "wu  jie"
Else
Text2 = Text2
End If

End If

a = a + 1
Loop

End Sub

Private Sub Command2_Click()
Text1 = ""
Text2 = ""

End Sub

Private Function fenjieyinzi(sa As String) As String
Dim X, a, B
X = sa
B = Int(Sqr(Val(X)) / 2)
If X = 3 Or X = 2 Then
a = True
Else
If Right(X, 1) Mod 2 = 0 Then
a = False
Else

For i = 3 To 2 * B + 1 Step 2
If InStr(X / i, ".") = 0 Then
a = False
Exit For

Else: a = True

End If
Next
End If
End If
If a = True Then
fenjieyinzi = "这是个素数"
Else
fenjieyinzi = "2*2"
End If

End Function
Private Function paixu1(a As String) As String
Dim i As Integer
Dim ak(), s105, cr(), f
s103 = a
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
   j1 = UBound(s105)
   Print j1
   For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    Print ak(1)
     
        For k = 1 To j1
           
             ReDim Preserve cr(1 To k)
            m = Val(ak(k))
            f(m) = ""
      Next
   
      n = 0
      m = f.Keys
      For i = 0 To f.Count - 1
          ReDim Preserve cr(1 To i + 1)
          cr(i + 1) = m(i)
      Next
     For i = 1 To UBound(cr) - 1
        For j = i + 1 To UBound(cr)
            If cr(i) > cr(j) Then
                temp = cr(j)
                cr(j) = cr(i)
                cr(i) = temp  'c数组是排序好的
            End If
        Next j
        
       ' If i Mod 20 = 0 Then
       ' s104 = s104 & temp & "/" & vbCrLf
       ' Else
       ' s104 = s104 & temp & "/"
       ' End If
    Next i
   
      For i = 1 To UBound(cr)
        If i Mod 20 = 0 Then
          s104 = s104 & cr(i) & "/" & vbCrLf
        Else
          s104 = s104 & cr(i) & "/"
        End If
     Next
         Print temp
         MsgBox "ok"
     MsgBox s104  '显示数组
     paixu1 = s104
End Function


Private Function paixu11(a3 As String, q As String) As String
a2 = Val(2)
Do While InStr(Val(Log(a3) / Log(a2)), ".") > 0 And a2 <= Val(q)
a2 = Val(a2) + 1
Loop

r = Log(a3) / Log(a2)
paixu11 = a2 & "^" & r
End Function


Private Function paixu(a As String) As String
Dim i As Integer
Dim ak(), s105, cr(), f
s103 = a
Set f = CreateObject("Scripting.Dictionary")
s105 = Split(s103, "/")
   j1 = UBound(s105)
   Print j1
   j2 = Val(j1)
   For k = 1 To j1
      n1 = n1 + 1
       ReDim Preserve ak(1 To n1)
      ak(n1) = s105(n1)
    Next
    Print ak(1)
     n = 0
        For k = 1 To j1
           For i = 1 To j1
             n = n + 1
             ReDim Preserve cr(1 To n)
            m = Val(ak(k)) + Val(ak(i))
            f(m) = ""
      Next
    Next
      n = 0
      
      m = f.Keys
      For i = 0 To j2
          ReDim Preserve cr(1 To i + 1)
          cr(i + 1) = m(i)
      Next
     For i = 1 To UBound(cr) - 1
        For j = i + 1 To UBound(cr)
            If cr(i) > cr(j) Then
                temp = cr(j)
                cr(j) = cr(i)
                cr(i) = temp  'c数组是排序好的
            End If
        Next j
        
       ' If i Mod 20 = 0 Then
       ' s104 = s104 & temp & "/" & vbCrLf
       ' Else
       ' s104 = s104 & temp & "/"
       ' End If
    Next i
   
      For i = 1 To UBound(cr)
        If i Mod 20 = 0 Then
          s104 = s104 & cr(i) & "/" & vbCrLf
        Else
          s104 = s104 & cr(i) & "/"
        End If
     Next
         Print temp
         MsgBox "ok"
     MsgBox s104  '显示数组
     paixu = s104
End Function