Private Sub cmdtoThunder_Click()
Dim Thunder As String
Thunder = df_var(1)
If Len(txtDecode.Text) <= 10 Then
txtEncode.Text = df_var(2)
Else
Set c1 = New Class1
txtEncode.Text = Thunder + c1.Base64_Encode(df_var(3) + txtDecode.Text + df_var(4))
End If
End Sub
Public Sub Class_Initialize()
Call df_var_initialize
End Sub
Public Sub df_var_initialize()
'=
df_var(1) = Chr(61)
'&h
df_var(2) = Chr(38) + Chr(104)
'&h
df_var(3) = Chr(38) + Chr(104)
End Sub
Public Function Base64_Encode(ByVal DecryptedText As String) As String
'加密函数
Dim c1, c2, c3 As Integer
Dim bytBuffer() As Byte
Dim w1 As Integer
Dim w2 As Integer
Dim w3 As Integer
Dim w4 As Integer
Dim n As Integer
Dim ansiLen As Integer
Dim retry As String
bytBuffer = StringToArray(DecryptedText)
ansiLen = LenB(StrConv(DecryptedText, vbFromUnicode)) '字符串的ANSI长度
For n = 0 To ansiLen - 1 Step 3
c1 = bytBuffer(n)
w1 = Int(c1 / 4)
If ansiLen - 1 >= n + 1 Then '说明还有第3位
c2 = bytBuffer(n + 1)
w2 = (c1 And 3) * 16 + Int(c2 / 16)
Else
w2 = (c1 And 3) * 16
w3 = -1
w4 = -1
GoTo tEnd
End If
If ansiLen - 1 >= n + 2 Then
c3 = bytBuffer(n + 2)
w3 = (c2 And 15) * 4 + Int(c3 / 64)
w4 = c3 And 63
Else
w4 = -1
GoTo tEnd
End If
tEnd:
retry = retry + mimeencode(w1) + mimeencode(w2) + mimeencode(w3) + mimeencode(w4)
Next
Base64_Encode = retry
End Function
Private Function mimeencode(w As Integer) As String
If w >= 0 Then mimeencode = Mid$(base64, w + 1, 1) Else: mimeencode = df_var(1)
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
Function AscToTxt(instr1 As String) As String
'ASC内码值到字符，支持中文
'进来时以内码形式进来，例如：32BBC6
'函数值为这个内码对应的字符-->"2黄"
Dim nlen As Integer
Dim astr1 As String
Dim strprew As String
Dim strtmp As String
Dim str4last As String
Dim i As Integer
Dim laststr As String
nlen = Len(instr1) '内码到字符
astr1 = instr1
strprew = ""
For i = 1 To nlen - 1 Step 2
strtmp = strprew & Mid(astr1, i, 2)
If CInt(df_var(2) & strtmp) < 128 Then
str4last = Chr(CLng(df_var(3) & strtmp))
strprew = ""
laststr = laststr & str4last
Else
strprew = strtmp
End If
Next i
AscToTxt = laststr
End Function
Private Function StringToArray(InString As String) As Byte()
'将字符串转入指针数组
Dim i As Integer, bytBuffer() As Byte
Dim z As Integer
ReDim bytBuffer(LenB(StrConv(InString, vbFromUnicode))) '根据字符串的ansi长度，重新定义字节缓冲的大小
bytBuffer = StrConv(InString, vbFromUnicode) '然后将ansi形式的字符串放入字节缓冲
StringToArray = bytBuffer
End Function
