Base64加密解密VB源码

小歆13年前软件源码13585
base64加密模块
用法:Base64Encode(‘加密字符')


Option Explicit
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
mOutByte(0) = tByte
tByte = (mInByte(1) And &HF) * 16 + (mInByte(2) And &H3C) / 4
mOutByte(1) = tByte
tByte = (mInByte(2) And &H3) * 64 + (mInByte(3) And &H3F)
mOutByte(2) = tByte
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

 
base64解密模块
用法:DecodeBase64String("解密字符")

Next
DecodeBase64Byte = Output
End Function

'将一个字节数组进行Base64编码,并返回字符串
Public Function EncodeBase64Byte(sValue() As Byte) As String
Dim lCtr As Long
Dim lPtr As Long
Dim lLen As Long
Dim sEncoded As String
Dim Bits8(1 To 3) As Byte
Dim Bits6(1 To 4) As Byte
Dim I As Integer
InitBase
For lCtr = 1 To UBound(sValue) + 1 Step 3
For I = 1 To 3
If lCtr + I - 2 <= UBound(sValue) Then
Bits8(I) = sValue(lCtr + I - 2)
lLen = 3
Else
Bits8(I) = 0
lLen = lLen - 1
End If
Next
Bits6(1) = (Bits8(1) And &HFC) \ 4
Bits6(2) = (Bits8(1) And &H3) * &H10 + (Bits8(2) And &HF0) \ &H10
Bits6(3) = (Bits8(2) And &HF) * 4 + (Bits8(3) And &HC0) \ &H40
Bits6(4) = Bits8(3) And &H3F
For lPtr = 1 To lLen + 1
sEncoded = sEncoded & psBase64Chr(Bits6(lPtr))
Next
Next
Select Case lLen + 1
Case 2: sEncoded = sEncoded & "=="
Case 3: sEncoded = sEncoded & "="
Case 4:
End Select
EncodeBase64Byte = sEncoded
End Function
Public Function EncodeBase64String(str2Encode As String) As String
Dim sValue() As Byte
sValue = StrConv(str2Encode, vbFromUnicode)
EncodeBase64String = EncodeBase64Byte(sValue)
End Function
Private Sub InitBase()
Dim iPtr As Integer
For iPtr = 0 To 63
psBase64Chr(iPtr) = Mid$(BASE64CHR, iPtr + 1, 1)
Next
End Sub







相关文章

VB格式输出函数Format的使用

VB格式输出函数可以使数值、日期或字符串按指定的格式输出。其格式为: Format(<表达式>[, <格式字符串>])...

VB URL编码函数

VB UTF-8 URL编码函数: Public Function UTF8_URLEncoding(szInput)  ...

ゆえばおしょうyい.jpg

【VB源码】余额宝收益值查询工具

名称:(支付宝)余额宝收益值查询工具V1.0 作者:小歆 说明:通过调用官网的“万份收益值”来计算“收益资金”,程序很简单,大牛勿喷! 源码下载: 余额宝查询...

VB爱心屏保

'运行后可以后到一个由圆画成的爱心,送给好孩呵呵 '分辨率=1024*768 '要生成文件的后缀名为scr '窗体样式要改为Me.BorderStyle = 0 Dim X1, Y1,...

Discuz附件下载权限绕过工具.png

[小歆][Discuz附件下载权限绕过工具][V1.1][2014.03.13]

Discuz附件下载权限绕过工具V1.1 本软件利用Discuz论坛的漏洞来下载论坛的附件。 【Discuz3.X的有部分好像已经失效了,自测,我刚刚测试了一个3.X论坛还是...

VB字符串函数大全

Abs(number) 返回绝对值。 Array(arglist) 创建一个数组。 Asc(string) 返回字符串第一个字符的ANSI码。 Atn(number) 返回反...

评论列表

爱好者
2021-01-05 16:51:04

DecodeBase64String("解密字符")这块代码能否放完整,多谢

发表评论    

◎欢迎参与讨论,请在这里发表您的看法、交流您的观点。