base64算法在vb(.net)中的实现

摘自:http://www.alixixi.com/weBuild/Subject40/weBuild/Subject40/200631911054.html
作者:[]

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,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,1))

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

w3 = mimedecode(Mid$(a,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))),n)

For i = 2 To Len(m)

s = s & "+" & Mult(CLng(Asc(Mid(m,i,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,nxt))

Else

tok = Val(Mid(ind,i))

End If

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

If Not nxt = 0 Then

i = nxt

Else

i = Len(ind)

End If

Next i

Decode = St

End Function