home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD5615592000.psc / RSA.bas < prev    next >
Encoding:
BASIC Source File  |  1999-09-03  |  4.6 KB  |  194 lines
  1. Attribute VB_Name = "RSA"
  2. Public key(1 To 3) As Long
  3. Private Const base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  4.  
  5. Public Sub GenKey()
  6. Dim d As Long, phi As Long, e As Long
  7. Dim m As Long, x As Long, q As Long
  8. Dim p As Long
  9. Randomize
  10. On Error GoTo top
  11. top:
  12. p = Rnd * 1000 \ 1
  13. If IsPrime(p) = False Then GoTo top
  14. Sel_q:
  15. q = Rnd * 1000 \ 1
  16. If IsPrime(q) = False Then GoTo Sel_q
  17. n = p * q \ 1
  18. phi = (p - 1) * (q - 1) \ 1
  19. d = Rnd * n \ 1
  20. If d = 0 Or n = 0 Or d = 1 Then GoTo top
  21. e = Euler(phi, d)
  22. If e = 0 Or e = 1 Then GoTo top
  23.  
  24. x = Mult(255, e, n)
  25. If Not Mult(x, d, n) = 255 Then
  26.     DoEvents
  27.     GoTo top
  28. ElseIf Mult(x, d, n) = 255 Then
  29.     key(1) = e
  30.     key(2) = d
  31.     key(3) = n
  32. End If
  33. End Sub
  34.  
  35. Private Function Euler(ByVal a As Long, ByVal b As Long) As Long
  36. On Error GoTo error2
  37. r1 = a: r = b
  38. p1 = 0: p = 1
  39. q1 = 2: q = 0
  40. n = -1
  41. Do Until r = 0
  42.     r2 = r1: r1 = r
  43.     p2 = p1: p1 = p
  44.     q2 = q1: q1 = q
  45.     n = n + 1
  46.     r = r2 Mod r1
  47.     c = r2 \ r1
  48.     p = (c * p1) + p2
  49.     q = (c * q1) + q2
  50. Loop
  51. s = (b * p1) - (a * q1)
  52. If s > 0 Then
  53.     x = p1
  54. Else
  55.     x = (0 - p1) + a
  56. End If
  57. Euler = x
  58. Exit Function
  59.  
  60. error2:
  61. Euler = 0
  62. End Function
  63.  
  64. Private Function Mult(ByVal x As Long, ByVal p As Long, ByVal m As Long) As Long
  65. y = 1
  66. On Error GoTo error1
  67. Do While p > 0
  68.     Do While (p / 2) = (p \ 2)
  69.         x = (x * x) Mod m
  70.         p = p / 2
  71.     Loop
  72.     y = (x * y) Mod m
  73.     p = p - 1
  74. Loop
  75. Mult = y
  76. Exit Function
  77.  
  78. error1:
  79. y = 0
  80. End Function
  81.  
  82. Private Function IsPrime(lngNumber As Long) As Boolean
  83. Dim lngCount As Long
  84. Dim lngSqr As Long
  85. Dim x As Long
  86.  
  87.     lngSqr = Sqr(lngNumber) ' get the int square root
  88.  
  89.     If lngNumber < 2 Then
  90.         IsPrime = False
  91.         Exit Function
  92.     End If
  93.  
  94.     lngCount = 2
  95.     IsPrime = True
  96.  
  97.     If lngNumber Mod lngCount = 0& Then
  98.         IsPrime = False
  99.         Exit Function
  100.     End If
  101.  
  102.     lngCount = 3
  103.  
  104.     For x& = lngCount To lngSqr Step 2
  105.         If lngNumber Mod x& = 0 Then
  106.             IsPrime = False
  107.             Exit Function
  108.         End If
  109.     Next
  110. End Function
  111.  
  112. Private Function Base64_Encode(DecryptedText As String) As String
  113. Dim c1, c2, c3 As Integer
  114. Dim w1 As Integer
  115. Dim w2 As Integer
  116. Dim w3 As Integer
  117. Dim w4 As Integer
  118. Dim n As Integer
  119. Dim retry As String
  120.    For n = 1 To Len(DecryptedText) Step 3
  121.       c1 = Asc(Mid$(DecryptedText, n, 1))
  122.       c2 = Asc(Mid$(DecryptedText, n + 1, 1) + Chr$(0))
  123.       c3 = Asc(Mid$(DecryptedText, n + 2, 1) + Chr$(0))
  124.       w1 = Int(c1 / 4)
  125.       w2 = (c1 And 3) * 16 + Int(c2 / 16)
  126.       If Len(DecryptedText) >= n + 1 Then w3 = (c2 And 15) * 4 + Int(c3 / 64) Else w3 = -1
  127.       If Len(DecryptedText) >= n + 2 Then w4 = c3 And 63 Else w4 = -1
  128.       retry = retry + mimeencode(w1) + mimeencode(w2) + mimeencode(w3) + mimeencode(w4)
  129.    Next
  130.    Base64_Encode = retry
  131. End Function
  132.  
  133. Private Function Base64_Decode(a As String) As String
  134. Dim w1 As Integer
  135. Dim w2 As Integer
  136. Dim w3 As Integer
  137. Dim w4 As Integer
  138. Dim n As Integer
  139. Dim retry As String
  140.  
  141.    For n = 1 To Len(a) Step 4
  142.       w1 = mimedecode(Mid$(a, n, 1))
  143.       w2 = mimedecode(Mid$(a, n + 1, 1))
  144.       w3 = mimedecode(Mid$(a, n + 2, 1))
  145.       w4 = mimedecode(Mid$(a, n + 3, 1))
  146.       If w2 >= 0 Then retry = retry + Chr$(((w1 * 4 + Int(w2 / 16)) And 255))
  147.       If w3 >= 0 Then retry = retry + Chr$(((w2 * 16 + Int(w3 / 4)) And 255))
  148.       If w4 >= 0 Then retry = retry + Chr$(((w3 * 64 + w4) And 255))
  149.    Next
  150.    Base64_Decode = retry
  151. End Function
  152.  
  153. Private Function mimeencode(w As Integer) As String
  154.    If w >= 0 Then mimeencode = Mid$(base64, w + 1, 1) Else mimeencode = ""
  155. End Function
  156.  
  157. Private Function mimedecode(a As String) As Integer
  158.    If Len(a) = 0 Then mimedecode = -1: Exit Function
  159.    mimedecode = InStr(base64, a) - 1
  160. End Function
  161.  
  162. Public Function Encode(ByVal Inp As String, ByVal e As Long, ByVal n As Long) As String
  163. Dim s As String
  164. s = ""
  165. m = Inp
  166.  
  167. If m = "" Then Exit Function
  168. s = Mult(CLng(Asc(Mid(m, 1, 1))), e, n)
  169. For i = 2 To Len(m)
  170.     s = s & "+" & Mult(CLng(Asc(Mid(m, i, 1))), e, n)
  171. Next i
  172. Encode = Base64_Encode(s)
  173. End Function
  174.  
  175. Public Function Decode(ByVal Inp As String, ByVal d As Long, ByVal n As Long) As String
  176. St = ""
  177. ind = Base64_Decode(Inp)
  178. For i = 1 To Len(ind)
  179.     nxt = InStr(i, ind, "+")
  180.     If Not nxt = 0 Then
  181.         tok = Val(Mid(ind, i, nxt))
  182.     Else
  183.         tok = Val(Mid(ind, i))
  184.     End If
  185.     St = St + Chr(Mult(CLng(tok), d, n))
  186.     If Not nxt = 0 Then
  187.         i = nxt
  188.     Else
  189.         i = Len(ind)
  190.     End If
  191. Next i
  192. Decode = St
  193. End Function
  194.