Public key(1 To 3) As Long 

Private Const base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrst 

uvwxyz0123456789+/" 

  

Public Sub GenKey() 

Dim d As Long, phi As Long, e As Long 

Dim m As Long, x As Long, q As Long 

Dim p As Long 

Randomize 

On Error GoTo top 

top: 

p = Rnd * 1000 \ 1 

If IsPrime(p) = False Then GoTo top 

Sel_q: 

q = Rnd * 1000 \ 1 

If IsPrime(q) = False Then GoTo Sel_q 

n = p * q \ 1 

phi = (p - 1) * (q - 1) \ 1 

d = Rnd * n \ 1 

If d = 0 Or n = 0 Or d = 1 Then GoTo top 

e = Euler(phi, d) 

If e = 0 Or e = 1 Then GoTo top 

  

x = Mult(255, e, n) 

If Not Mult(x, d, n) = 255 Then 

    DoEvents 

    GoTo top 

ElseIf Mult(x, d, n) = 255 Then 

    key(1) = e 

    key(2) = d 

    key(3) = n 

End If 

End Sub 

  

Private Function Euler(ByVal a As Long, ByVal b As Long) As Long 

On Error GoTo error2 

r1 = a: r = b 

p1 = 0: p = 1 

q1 = 2: q = 0 

n = -1 

Do Until r = 0 

    r2 = r1: r1 = r 

    p2 = p1: p1 = p 

    q2 = q1: q1 = q 

    n = n + 1 

    r = r2 Mod r1 

    c = r2 \ r1 

    p = (c * p1) + p2 

    q = (c * q1) + q2 

Loop 

s = (b * p1) - (a * q1) 

If s > 0 Then 

    x = p1 

Else 

    x = (0 - p1) + a 

End If 

Euler = x 

Exit Function 

  

error2: 

Euler = 0 

End Function 

  

Private Function Mult(ByVal x As Long, ByVal p As Long, ByVal m As Lon 

g) As Long 

y = 1 

On Error GoTo error1 

Do While p > 0 

    Do While (p / 2) = (p \ 2) 

        x = (x * x) Mod m 

        p = p / 2 

    Loop 

    y = (x * y) Mod m 

    p = p - 1 

Loop 

Mult = y 

Exit Function 

  

error1: 

y = 0 

End Function 

  

Private Function IsPrime(lngNumber As Long) As Boolean 

Dim lngCount As Long 

Dim lngSqr As Long 

Dim x As Long 

  

    lngSqr = Sqr(lngNumber) ' get the int square root 

  

    If lngNumber < 2 Then 

        IsPrime = False 

        Exit Function 

    End If 

  

    lngCount = 2 

    IsPrime = True 

  

    If lngNumber Mod lngCount = 0& Then 

        IsPrime = False 

        Exit Function 

    End If 

  

    lngCount = 3 

  

    For x& = lngCount To lngSqr Step 2 

        If lngNumber Mod x& = 0 Then 

            IsPrime = False 

            Exit Function 

        End If 

    Next 

End Function 

  

Private Function Base64_Encode(DecryptedText As String) As String 

Dim c1, c2, c3 As Integer 

Dim w1 As Integer 

Dim w2 As Integer 

Dim w3 As Integer 

Dim w4 As Integer 

Dim n As Integer 

Dim retry As String 

   For n = 1 To Len(DecryptedText) Step 3 

      c1 = Asc(Mid$(DecryptedText, n, 1)) 

      c2 = Asc(Mid$(DecryptedText, n + 1, 1) + Chr$(0)) 

      c3 = Asc(Mid$(DecryptedText, n + 2, 1) + Chr$(0)) 

      w1 = Int(c1 / 4) 

      w2 = (c1 And 3) * 16 + Int(c2 / 16) 

      If Len(DecryptedText) >= n + 1 Then w3 = (c2 And 15) * 4 + Int(c 

3 / 64) Else w3 = -1 

      If Len(DecryptedText) >= n + 2 Then w4 = c3 And 63 Else w4 = -1 

  

      retry = retry + mimeencode(w1) + mimeencode(w2) + mimeencode(w3) 

+ mimeencode(w4) 

   Next 

   Base64_Encode = retry 

End Function 

  

Private Function Base64_Decode(a As String) As String 

Dim w1 As Integer 

Dim w2 As Integer 

Dim w3 As Integer 

Dim w4 As Integer 

Dim n As Integer 

Dim retry As String 

  

   For n = 1 To Len(a) Step 4 

      w1 = mimedecode(Mid$(a, n, 1)) 

      w2 = mimedecode(Mid$(a, n + 1, 1)) 

      w3 = mimedecode(Mid$(a, n + 2, 1)) 

      w4 = mimedecode(Mid$(a, n + 3, 1)) 

      If w2 >= 0 Then retry = retry + Chr$(((w1 * 4 + Int(w2 / 16)) An 

d 255)) 

      If w3 >= 0 Then retry = retry + Chr$(((w2 * 16 + Int(w3 / 4)) An 

d 255)) 

      If w4 >= 0 Then retry = retry + Chr$(((w3 * 64 + w4) And 255)) 

   Next 

   Base64_Decode = retry 

End Function 

  

Private Function mimeencode(w As Integer) As String 

   If w >= 0 Then mimeencode = Mid$(base64, w + 1, 1) Else mimeencode 

= "" 

End Function 

  

Private Function mimedecode(a As String) As Integer 

   If Len(a) = 0 Then mimedecode = -1: Exit Function 

   mimedecode = InStr(base64, a) - 1 

End Function 

  

Public Function Encode(ByVal Inp As String, ByVal e As Long, ByVal n A 

s Long) As String 

Dim s As String 

s = "" 

m = Inp 

  

If m = "" Then Exit Function 

s = Mult(CLng(Asc(Mid(m, 1, 1))), e, n) 

For i = 2 To Len(m) 

    s = s & "+" & Mult(CLng(Asc(Mid(m, i, 1))), e, n) 

Next i 

Encode = Base64_Encode(s) 

End Function 

  

Public Function Decode(ByVal Inp As String, ByVal d As Long, ByVal n A 

s Long) As String 

St = "" 

ind = Base64_Decode(Inp) 

For i = 1 To Len(ind) 

    nxt = InStr(i, ind, "+") 

    If Not nxt = 0 Then 

        tok = Val(Mid(ind, i, nxt)) 

    Else 

        tok = Val(Mid(ind, i)) 

    End If 

    St = St + Chr(Mult(CLng(tok), d, n)) 



    If Not nxt = 0 Then 

        i = nxt 

    Else 

        i = Len(ind) 

    End If 

Next i 

Decode = St 

End Function