Implementation of RSA encryption algorithm in VB

Encryption | algorithm-forgot where it was extracted from

The implementation of ' RSA encryption algorithm in VB


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) * + Int (C2/16)
If Len (Decryptedtext) >= n + 1 Then W3 = (C2 and) * 4 + Int (c
3/64) Else W3 =-1
If Len (Decryptedtext) >= n + 2 Then W4 = C3 and-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 * + Int (W3/4))
D 255))
If W4 >= 0 Then retry = retry + chr$ ((W3 * + 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

' To be Continue ...