Base64编码

| |
[不指定 2013/12/22 16:48 | by admin ]

'****************************************************************************
‘转载注明出处,红防安全网 http://blog.hkfx.net QQ:3925993
'****************************************************************************
Public key(1 To 3) As Long
Private Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
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 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)
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 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(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
Base64_Encode = retry
End Function
Public 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)) 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
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 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 = Base64_Encode(s)
End Function
Public Function Decode(ByVal Inp As String, ByVal d As Long, ByVal n As 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
'-----------------------------------------------------------------------以上命名为Base64 .bas



'-----------------------------------------------------------------------以下为类型模Base64.cls
'****************************************************************************
'黑客代码
'网    站:http://hkfx.net.com/
'e-mail  :913636668@qq.com
'OICQ    :913636668
'****************************************************************************
Option Explicit
'Base64编码、解码类
'Base64编码函数:Base64Encode
'Instr1    编码前字符串
'Outstr1    编码后字符串
Public Function Base64Encode(InStr1 As String) As String
    Dim mInByte(3) As Byte, mOutByte(4) As Byte
    Dim myByte As Byte
    Dim i As Integer, LenArray As Integer, j As Integer
    Dim myBArray() As Byte
    Dim OutStr1 As String
  
    myBArray() = StrConv(InStr1, vbFromUnicode)
    LenArray = UBound(myBArray) + 1
    For i = 0 To LenArray Step 3
        If LenArray - i = 0 Then
            Exit For
        End If
        If LenArray - i = 2 Then
            mInByte(0) = myBArray(i)
            mInByte(1) = myBArray(i + 1)
            Base64EncodeByte mInByte, mOutByte, 2
        ElseIf LenArray - i = 1 Then
            mInByte(0) = myBArray(i)
            Base64EncodeByte mInByte, mOutByte, 1
        Else
            mInByte(0) = myBArray(i)
            mInByte(1) = myBArray(i + 1)
            mInByte(2) = myBArray(i + 2)
            Base64EncodeByte mInByte, mOutByte, 3
        End If
        For j = 0 To 3
            OutStr1 = OutStr1 & Chr(mOutByte(j))
        Next j
    Next i
    Base64Encode = OutStr1
End Function
Private Sub Base64EncodeByte(mInByte() As Byte, mOutByte() As Byte, Num As Integer)
   Dim tByte As Byte
   Dim i As Integer
   If Num = 1 Then
       mInByte(1) = 0
       mInByte(2) = 0
   ElseIf Num = 2 Then
       mInByte(2) = 0
   End If
   tByte = mInByte(0) And &HFC
   mOutByte(0) = tByte / 4
   tByte = ((mInByte(0) And &H3) * 16) + (mInByte(1) And &HF0) / 16
   mOutByte(1) = tByte
   tByte = ((mInByte(1) And &HF) * 4) + ((mInByte(2) And &HC0) / 64)
   mOutByte(2) = tByte
   tByte = (mInByte(2) And &H3F)
   mOutByte(3) = tByte
   For i = 0 To 3
       If mOutByte(i) >= 0 And mOutByte(i) <= 25 Then
           mOutByte(i) = mOutByte(i) + Asc("A")
       ElseIf mOutByte(i) >= 26 And mOutByte(i) <= 51 Then
           mOutByte(i) = mOutByte(i) - 26 + Asc("a")
       ElseIf mOutByte(i) >= 52 And mOutByte(i) <= 61 Then
           mOutByte(i) = mOutByte(i) - 52 + Asc("0")
       ElseIf mOutByte(i) = 62 Then
           mOutByte(i) = Asc("+")
       Else
           mOutByte(i) = Asc("/")
       End If
   Next i
   If Num = 1 Then
       mOutByte(2) = Asc("=")
       mOutByte(3) = Asc("=")
   ElseIf Num = 2 Then
       mOutByte(3) = Asc("=")
   End If
End Sub
Public Function Base64Decode(InStr1 As String) As String
   Dim mInByte(4) As Byte, mOutByte(3) As Byte
   Dim i As Integer, LenArray As Integer, j As Integer
   Dim myBArray() As Byte
   Dim OutStr1 As String
   Dim tmpArray() As Byte
   myBArray() = StrConv(InStr1, vbFromUnicode)
   LenArray = UBound(myBArray)
   ReDim tmpArray(((LenArray + 1) / 4) * 3)
    j = 0
  
    For i = 0 To LenArray Step 4
       If LenArray - i = 0 Then
           Exit For
Else
            mInByte(0) = myBArray(i)
            mInByte(1) = myBArray(i + 1)

            mInByte(2) = myBArray(i + 2)
            mInByte(3) = myBArray(i + 3)
            Base64DecodeByte mInByte, mOutByte, 4
        End If
        tmpArray(j * 3) = mOutByte(0)
        tmpArray(j * 3 + 1) = mOutByte(1)
        tmpArray(j * 3 + 2) = mOutByte(2)
        j = j + 1
    Next i
    Base64Decode = BinaryToString(tmpArray)
End Function
Private Sub Base64DecodeByte(mInByte() As Byte, mOutByte() As Byte, ByteNum As Integer)
    Dim tByte As Byte
    Dim i As Integer
    ByteNum = 0
    For i = 0 To 3
        If mInByte(i) >= Asc("A") And mInByte(i) <= Asc("Z") Then
            mInByte(i) = mInByte(i) - Asc("A")
        ElseIf mInByte(i) >= Asc("a") And mInByte(i) <= Asc("z") Then
            mInByte(i) = mInByte(i) - Asc("a") + 26
        ElseIf mInByte(i) >= Asc("0") And mInByte(i) <= Asc("9") Then
            mInByte(i) = mInByte(i) - Asc("0") + 52
        ElseIf mInByte(i) = Asc("+") Then
            mInByte(i) = 62
        ElseIf mInByte(i) = Asc("/") Then
            mInByte(i) = 63
        Else '"="
            ByteNum = ByteNum + 1
            mInByte(i) = 0
        End If
    Next i
    '取前六位
    tByte = (mInByte(0) And &H3F) * 4 + (mInByte(1) And &H30) / 16
    '0的六位和1的前两位
    mOutByte(0) = tByte
    tByte = (mInByte(1) And &HF) * 16 + (mInByte(2) And &H3C) / 4
    '1的后四位和2的前四位
    mOutByte(1) = tByte
    tByte = (mInByte(2) And &H3) * 64 + (mInByte(3) And &H3F)
    mOutByte(2) = tByte
    '2的后两位和3的六位
End Sub
Private Function BinaryToString(ByVal BinaryStr As Variant) As String '二进制转换为字符串
  Dim lnglen As Long
  Dim tmpBin As Variant
  Dim strC As String
  Dim skipflag As Long
  Dim i As Long
  skipflag = 0
  strC = ""

  If Not IsNull(BinaryStr) Then
      lnglen = LenB(BinaryStr)
      For i = 1 To lnglen
          If skipflag = 0 Then
            tmpBin = MidB(BinaryStr, i, 1)
            If AscB(tmpBin) > 127 Then
                strC = strC & Chr(AscW(MidB(BinaryStr, i + 1, 1) & tmpBin))
                skipflag = 1
            Else
                strC = strC & Chr(AscB(tmpBin))
            End If
          Else
            skipflag = 0
          End If
      Next
    End If
    BinaryToString = strC
End Function
Private Function StringToBinary(ByVal VarString As String) As Variant '字符串转成二进制
  Dim strBin As Variant
  Dim varchar As Variant
  Dim varasc As Long
  Dim varlow, varhigh
  Dim i As Long
  strBin = ""

  For i = 1 To Len(VarString)
      varchar = Mid(VarString, i, 1)
      varasc = Asc(varchar)
      If varasc < 0 Then
          varasc = varasc + 65535
      End If
      If varasc > 255 Then
          varlow = Left(Hex(Asc(varchar)), 2)
          varhigh = Right(Hex(Asc(varchar)), 2)
          strBin = strBin & ChrB("&H" & varlow) & ChrB("&H" & varhigh)
      Else
          strBin = strBin & ChrB(AscB(varchar))
      End If
  Next
  StringToBinary = strBin
End Function


'----------------------------------------------------------以下为窗口代码
'****************************************************************************
'编码
Private Sub Command1_Click()
   Dim dih As New Class1
   Text2 = dih.Base64Encode(Text1)
End Sub
'解码
Private Sub Command2_Click()
   Dim dih As New Class1
   Text3 = dih.Base64Decode(Text2)
End Sub
程序源码 | 评论(0) | 引用(0) | 阅读(2313)