base65mod.bas

这只是一个很简单的Base64编码模块

Attribute VB_Name = "Base65Mod"
'使用方法：Base64_Encode(Text1.Text)
Option Explicit

Private key(1 To 3) As Long
Private Const base64 = "@bCd3HIFGjKLnMRST0PQUWVxYZABcDefghiJk1Nmoqstpr " + _
"uwvXzy567Ol2E894+/"

Private 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 Long) 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

Function Base65_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(c3 / 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
   Base65_Encode = retry
End Function

Function Base65_Decode(a As String) As String
Dim w1 As Integer
Dim w2 As Integer
Dim w3 As Integer
Dim w4 As Integer
Dim n
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)) And 255))
      If w3 >= 0 Then retry = retry + Chr$(((w2 * 16 + Int(w3 / 4)) And 255))
      If w4 >= 0 Then retry = retry + Chr$(((w3 * 64 + w4) And 255))
   Next n
   Base65_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

Private Function Encode(ByVal Inp As String, ByVal e As Long, ByVal n As 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 = Base65_Encode(s)
End Function

Private Function Decode(ByVal Inp As String, ByVal d As Long, ByVal n As Long) As String
St = ""
ind = Base65_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