'**************************************
'Windows API/Global Declarations for :Fast 64bit RSA Encryption Algorithm
'**************************************
Public key(1 To 3) As Double
Public p As Double, q As Double
Public PHI As Double
Public Sub keyGen()
'Generates the keys for E, D and N
Dim E#, D#, N#
Const PQ_UP As Integer = 9999 'set upper limit of random number
Const PQ_LW As Integer = 3170 'set lower limit of random number
Const KEY_LOWER_LIMIT As Long = 10000000 'set for 64bit minimum
p = 0: q = 0
Randomize
Do Until D > KEY_LOWER_LIMIT 'makes sure keys are 64bit minimum
Do Until IsPrime(p) And IsPrime(q) ' make sure q and q are primes
p = Int((PQ_UP - PQ_LW + 1) * Rnd + PQ_LW)
q = Int((PQ_UP - PQ_LW + 1) * Rnd + PQ_LW)
Loop
 N = p * q
 PHI = (p - 1) * (q - 1)
 E = GCD(PHI)
 D = Euler(E, PHI)
Loop
 key(1) = E
 key(2) = D
 key(3) = N
 
End Sub
Private Function Euler(E3 As Double, PHI3 As Double) As Double
'genetates D from (E and PHI) using the Euler algorithm
On Error Resume Next
Dim u1#, u2#, u3#, v1#, v2#, v3#, q#
Dim t1#, t2#, t3#, z#, uu#, vv#, inverse#
u1 = 1
u2 = 0
u3 = PHI3
v1 = 0
v2 = 1
v3 = E3
Do Until (v3 = 0)
 q = Int(u3 / v3)
 t1 = u1 - q * v1
 t2 = u2 - q * v2
 t3 = u3 - q * v3
 u1 = v1
 u2 = v2
 u3 = v3
 v1 = t1
 v2 = t2
 v3 = t3
 z = 1
Loop
uu = u1
vv = u2
If (vv < 0) Then
inverse = vv + PHI3
Else
 inverse = vv
End If
Euler = inverse
End Function
Private Function GCD(nPHI As Double) As Double
'generates a random number relatively prime to PHI
On Error Resume Next
Dim nE#, y#
Const N_UP = 99999999 'set upper limit of random number for E
Const N_LW = 10000000 'set lower limit of random number for E
Randomize
nE = Int((N_UP - N_LW + 1) * Rnd + N_LW)
top:
 x = nPHI Mod nE
 y = x Mod nE
 If y <> 0 And IsPrime(nE) Then
 GCD = nE
 Exit Function
 Else
 nE = nE + 1
 End If
 
 GoTo top
End Function
Private Function IsPrime(lngNumber As Double) As Boolean
'Returns 'True' if lngNumber is a prime
 
On Error Resume Next
Dim lngCount#
Dim lngSqr#
Dim x#
lngSqr = Int(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
Public Function Mult(ByVal x As Double, ByVal p As Double, ByVal m As Double) As Double
'encrypts, decrypts values passed to the function.. e.g.
'Mult = M^E mod N (encrypt) where M = x , E = p, N = m
'Mult = M^D mod N (decrypt)
On Error GoTo error1
 
y = 1
 
 Do While p > 0
 Do While (p / 2) = Int((p / 2))
x = nMod((x * x), m)
p = p / 2
 Loop
 y = nMod((x * y), m)
 p = p - 1
 Loop
 Mult = y
 Exit Function
error1:
y = 0
End Function
Private Function nMod(x As Double, y As Double) As Double
'this function replaces the Mod command. instead of z = x Mod y
'it is now z = nMod(x,y)
On Error Resume Next
Dim z#
z = x - (Int(x / y) * y)
nMod = z
End Function
Public Function enc(tIp As String, eE As Double, eN As Double) As String
'returns the long value of the characters, chained with a +
'e.g. 12345678+23456789+ etc..
'**Taken out encryption algorithm to simplify program**
On Error Resume Next
Dim encSt As String
encSt = ""
e2st = ""
 
 If tIp = "" Then Exit Function
 For i = 1 To Len(tIp)
 encSt = encSt & Mult(CLng(Asc(Mid(tIp, i, 1))), eE, eN) & "+"
 Next i
'** put your encryption algorithm code here **
enc = encSt
 
End Function
Public Function dec(tIp As String, dD As Double, dN As Double) As String
'returns the characters from the long values
'e.g A = 12345678, B = 23456789 etc..
'**Taken out decryption algorithm to simplify program**
On Error Resume Next
Dim decSt As String
decSt = ""
'** put your decryption algorithm code here **
For z = 1 To Len(tIp)
 ptr = InStr(z, tIp, "+")
 tok = Val(Mid(tIp, z, ptr))
 decSt = decSt + Chr(Mult(tok, dD, dN))
 z = ptr
Next z
dec = decSt
End Function