几个vb小程序

ysr

Private Function qniyuan(sa As String, sb As String) As String
Dim n, p, A, B, c, d, r
  n = Trim(sa)
  p = Trim(sb)
  A = 1
  B = 0
  c = 0
  d = 1
  If Len(n) < 15 And Len(p) < 15 Then
  
  If Val(n) > Val(p) Then
     m = n
     q = p
     s1 = 1
  Else
     m = p
     q = n
     s1 = 0
  End If
Do Until InStr(Val(m) / Val(q), ".") = 0
    s = Mid(Val(m) / Val(q), 1, Abs(InStr(Val(m) / Val(q), ".") - 1))
     r = m - Mid(Val(m) / Val(q), 1, Abs(InStr(Val(m) / Val(q), ".") - 1)) * Val(q)
     s1 = s1 + 1
     If s1 Mod 2 = 1 Then
     A = A
     B = A * s + B
     c = c
     d = c * s + d
     Else
     B = B
     A = A + B * s
     d = d
     c = c + d * s
     End If
     m = q
     q = r
  Loop
  If Val(A + B * m) = p Then
  B = B
  A = A + B * (m - 1)
  d = d
  c = c + d * (m - 1)
  Else
  If Val(B + A * m) = p Then
  A = A
  B = B + A * m
  c = c
  d = d + c * m
  Else
  B = B
  A = A + B * (m - 1)
  d = d
  c = c + d * (m - 1)
  End If
  End If
x = Mid(Val(A + B) / Val(p), 1, Abs(InStr(Val(A + B) / Val(p), ".") - 1))
  Y = Mid(Val(c + d) / Val(n), 1, Abs(InStr(Val(c + d) / Val(n), ".") - 1))
  
  
  Else
  
  If MBJC(Trim(n), Trim(p)) >= 1 Then
  m = n
  q = p
  s1 = 1
  Else
  m = p
  q = n
  s1 = 0
  End If
  Do Until zhengchuqyushu(MCC1(Trim(m), Trim(q))) = 0
  s = zhengchuqy(MCC1(Trim(m), Trim(q)))
  r = zhengchuqyushu(MCC1(Trim(m), Trim(q)))
  s1 = s1 + 1
  If s1 Mod 2 = 1 Then
  A = A
  B = MPC1(MbC(Trim(A), Trim(s)), Trim(B))
  c = c
  d = MPC1(MbC(Trim(c), Trim(s)), Trim(d))
  Else
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), Trim(s)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), Trim(s)))
  End If
  
  m = q
  q = r
  Loop
  
  If MPC1(Trim(A), MbC(Trim(B), Trim(m))) = p Then
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
  Else
  If MPC1(Trim(B), MbC(Trim(A), Trim(m))) = p Then
  A = A
  B = MPC1(Trim(B), MbC(Trim(A), Trim(m)))
  c = c
  d = MPC1(Trim(d), MbC(Trim(c), Trim(m)))
  Else
  B = B
  A = MPC1(Trim(A), MbC(Trim(B), MPC(Trim(m), 1)))
  d = d
  c = MPC1(Trim(c), MbC(Trim(d), MPC(Trim(m), 1)))
  End If
  End If
Do While Left(A, 1) = "0"
    A = Mid(A, 2)
Loop
  
  End If
  
  qniyuan = A
End Function

ysr

Private Function zzxc(sa As String, sb As String) As String
Dim A, B, c, d, r
  A = Trim(sa)
  B = Trim(sb)
  If Len(A) < 15 And Len(B) < 15 Then
  
  If Val(A) > Val(B) Then
     c = A
     d = B
  Else
     c = B
     d = A
  End If
Do Until InStr(Val(c) / Val(d), ".") = 0
     r = c - Mid(Val(c) / Val(d), 1, Abs(InStr(Val(c) / Val(d), ".") - 1)) * Val(d)
     c = d
     d = r
  Loop
  
  Else
  
  If MBJC(Trim(A), Trim(B)) >= 1 Then
  c = A
  d = B
  Else
  c = B
  d = A
  End If
  Do Until zhengchuqyushu(MCC1(Trim(c), Trim(d))) = 0
  r = zhengchuqyushu(MCC1(Trim(c), Trim(d)))
  c = d
  d = r
  Loop
  End If

  
  zzxc = d
  
End Function

ysr

Dim pri(200000000) As Byte

Sub 按钮1_Click()
  pritab
End Sub

Sub pritab()
  '用字节位筛法生成16亿以内的素数表
  Dim i As Long, j As Long, b(8) As Byte, c As Byte, k As Long, l As Long, t As Double
  j = 1
  t = Timer
  For i = 0 To 7
    b(i) = j
    j = j * 2       '位运算值初始化
  Next
  For i = 0 To 200000000
    pri(i) = 170    '先假设所有奇数都是素数
  Next
  pri(0) = 172      '0,1不是素数，2是素数
  i = 3
  While i * i <= 1600000000
    If (pri(Int(i / 8)) And b(i Mod 8)) > 0 Then
      j = i * i
      While j <= 1600000000
        If (pri(Int(j / 8)) And b(j Mod 8)) > 0 Then
          c = b(j Mod 8) Xor 255
          pri(Int(j / 8)) = pri(Int(j / 8)) And c
        End If
        j = j + i * 2
      Wend
    End If
    i = i + 2
  Wend
  k = 0
  j = 0
  For i = 2 To 1600000000
    If (pri(Int(i / 8)) And b(i Mod 8)) > 0 Then
      If i - l = 2 Then j = j + 1
      k = k + 1
      l = i
    End If
  Next
  MsgBox "总素数：" & k & ",最大素数：" & l & "，孪生素数对：" & j & ",用时：" & Timer - t & "秒"
End Sub

ysr

总素数：79451833,最大素数：1599999983，孪生素数对：5223983,用时：746.542000000002秒

ysr

Dim pri(200000000) As Byte

Private Sub Command1_Click()
'用字节位筛法生成16亿以内的素数表
  Dim i As Long, j As Long, b(8) As Byte, c As Byte, k As Long, l As Long, t As Double
  j = 1
  t = Timer
  For i = 0 To 7
    b(i) = j
    j = j * 2       '位运算值初始化
  Next
  For i = 0 To 200000000
    pri(i) = 170    '先假设所有奇数都是素数
  Next
  pri(0) = 172      '0,1不是素数，2是素数
  i = 3
  While i * i <= 1600000000
    If (pri(Int(i / 8)) And b(i Mod 8)) > 0 Then
      j = i * i
      While j <= 1600000000
        If (pri(Int(j / 8)) And b(j Mod 8)) > 0 Then
          c = b(j Mod 8) Xor 255
          pri(Int(j / 8)) = pri(Int(j / 8)) And c
        End If
        j = j + i * 2
      Wend
    End If
    i = i + 2
  Wend
  k = 0
  j = 0
  For i = 2 To 1600000000
    If (pri(Int(i / 8)) And b(i Mod 8)) > 0 Then
      If i - l = 2 Then j = j + 1
      k = k + 1
      l = i
    End If
  Next
  MsgBox "总素数：" & k & ",最大素数：" & l & "，孪生素数对：" & j & ",用时：" & Timer - t & "秒"
  
  Text1 = "总素数：" & k & ",最大素数：" & l & "，孪生素数对：" & j & ",用时：" & Timer - t & "秒"
End Sub

ysr

加强筛连乘积公式结果： 整数1600000000  其方根内最大素数39989 方根内的素数个数m=4203 (方根为)40000  有39999个区间，其中每个区间孪生素数对个数的平均值130.546527593775  总对数为5221730.5572234

ysr

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 Sub Command1_Click()
Dim a, b
a = Val(Text1)
m = Sqr(a)
m1 = Int(m)
a3 = a / 6
a2 = m1
a1 = 3
s = 1
b = 1
Do While a2 <= m And InStr(fenjieyinzi(Val(a2)), "*") <> 0
a2 = a2 - 1
Loop
Do While a1 <= a2
c = fenjieyinzi(Val(a1))
If InStr(Trim(c), "*") = 0 Then
s = s + 1
b = b * Val(1 - 2 / a1)
Else
s = s
End If
a1 = a1 + 2
Loop
a4 = a1
If a <= 10000 Then
B1 = a3 * b * 3 + 1
Else
Do While a4 <= 2 * m1
c = fenjieyinzi(Val(a4))
If InStr(Trim(c), "*") = 0 Then

b = b * Val(1 - 2 / a4)
Else
s = s
End If
a4 = a4 + 2
Loop
B1 = a3 * b * 3 + 1
End If
If a <= 8 Then
B1 = (B1 + 2) / 3
Text2 = " 加强筛连乘积公式结果： 整数" & a & "  其方根内最大素数" & a2 & " 方根内的素数个数m=" _
& s & "  有" & m1 - 1 & "个区间，其中每个区间的孪生素数对个数的平均值" & B1 / m1 & "  总对数为" & B1 - 1
Else
Text2 = " 加强筛连乘积公式结果： 整数" & a & "  其方根内最大素数" & a2 & " 方根内的素数个数m=" _
& s & " (方根为)" & m & "  有" & m1 - 1 & "个区间，其中每个区间孪生素数对个数的平均值" & B1 / (m1 - 1) & "  总对数为" & B1
End If

End Sub

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

End Sub

ysr

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 x Mod 2 = 0 Then
a = False
Else

For I = 3 To 2 * b + 1 Step 2
If x Mod 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 Sub Command1_Click()
Dim a, b
a = Val(Text1)
m = Sqr(a)
m1 = Int(m)
a3 = a / 6
a2 = m1
a1 = 3
s = 1
b = 1
Do While a2 <= m And InStr(fenjieyinzi(Val(a2)), "*") <> 0
a2 = a2 - 1
Loop
Do While a1 <= a2
c = fenjieyinzi(Val(a1))
If InStr(Trim(c), "*") = 0 Then
s = s + 1
b = b * Val(1 - 2 / a1)
Else
s = s
End If
a1 = a1 + 2
Loop
a4 = a1
If a <= 10000 Then
B1 = a3 * b * 3 + 1
Else
Do While a4 <= 2 * m1
c = fenjieyinzi(Val(a4))
If InStr(Trim(c), "*") = 0 Then

b = b * Val(1 - 2 / a4)
Else
s = s
End If
a4 = a4 + 2
Loop
B1 = a3 * b * 3 + 1
End If
If a <= 8 Then
B1 = (B1 + 2) / 3
Text2 = " 加强筛连乘积公式结果： 整数" & a & "  其方根内最大素数" & a2 & " 方根内的素数个数m=" _
& s & "  有" & m1 - 1 & "个区间，其中每个区间的孪生素数对个数的平均值" & B1 / m1 & "  总对数为" & B1 - 1
Else
Text2 = " 加强筛连乘积公式结果： 整数" & a & "  其方根内最大素数" & a2 & " 方根内的素数个数m=" _
& s & " (方根为)" & m & "  有" & m1 - 1 & "个区间，其中每个区间孪生素数对个数的平均值" & B1 / (m1 - 1) & "  总对数为" & B1
End If

End Sub

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

End Sub

ysr

Public Function DeleteSpace(Tmp As String) As String
   Dim Inst As Integer
   Do
       Tmp = Replace(Tmp, " ", "")
       DoEvents
       Inst = InStr(Tmp, " ")
   Loop While Inst > 0
   DeleteSpace = Tmp
End Function

ysr

Public Function DeleteSpace(Tmp As String) As String
Dim i As Long, j As Long, k As Long
A = Trim(Tmp)
B = ""
k = Len(A)
For i = 1 To k
j = Asc(Mid(A, i))
If j <> 10 And j <> 13 And j <> 32 And j <> Asc(" ") Then '最后一个条件是全角空格
B = B & Chr(j)
End If
Next
DeleteSpace = B
End Function