'************************************** 'Windows API/Global Declarations for :Fa ' st 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 pr ' ime 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 character ' s, chained with a + 'e.g. 12345678+23456789+ etc.. '**Taken out encryption algorithm to sim ' plify 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 h ' ere ** enc = encSt End Function Public Function dec(tIp As String, dD As Double, dN As Double) As String 'returns the characters from the long va ' lues 'e.g A = 12345678, B = 23456789 etc.. '**Taken out decryption algorithm to sim ' plify program** On Error Resume Next Dim decSt As String decSt = "" '** put your decryption algorithm code h ' ere ** 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