base64加密vb
大家好，我是阿萨。昨天和开发同学一起开会的时候。开发同学说到了用Base64编码，我立即说 不能使用Base64加密。然后开发来了一句Base64不是加密算法。当时懵了。默默记下这个知识点，回来学习下。
先给大家讲解下我为什么会有不能使用Base64加密的意识。很多年前，我遇到的第一个安全问题，就是敏感数据用Base64加密了。 事情起因是，我们接到一个bug，说有个敏感字段使用Base64在前端加密了，然后传给后端了。
基于之前的小故事，对于使用了Base64编码的地方就觉得不安全。这也是为什么会对开发说不能用Base64加密了，
今天我们就来学习下Base64编码。
一，Base64编码的由来。
传说，最开始互联网电子邮件都是英文的，后来互联网传到中国后，互联网电子邮件汉字就不认识了。所以就有了Base64编码，把中文变成可识别的英文。然后Base64编码被广泛用到各行各业。
以上只是传说。真实的由来，就不得而知了。
下面我们从计算机的底层传输过程中。它分为可见字符和不可见字符。可见字符比如我们熟知的ASCII码。
还有一些不可见的控制字符（0~31以及127），比如回车，换行等以及一些二进制数据都是不可见字符。
这些不可见字符在一些硬件，比如交换机，路由器以及网关等识别或者解析错误，导致错误发生，所以就有了Base64编码的市场。因此Base64产生了。
二，Base64 编码的原理
Base64编码就是要把不可见的字符转换成常见的64个字符的过程。
这64个字符是哪些呢？
那么它工作原理是啥呢？
1） 首先把整段传输内容全部划分成三个字节一组。这里就有了24bit了.
2） 然后把24bit 分成四组。每一组就有6bit
3）在6bit的最前面添加2个0，这样就有了8bit
4）把这8bit 转换成一个字节。查找上表中对应字符。所有其他分组内容按照这样的处理逻辑处理下。就得到了Base64的编码后字符。
注意，如果不够三字节，用0填到三字节，同时补充了多少个字节的0，末尾就添加就几个=。
分别图示下以上过程：
三个A
2个A，补充一个0
1个A，补充2个0
三，总结
Base64编码不是用来加密的，也不是加密算法。它只是用来编码的。切记不可用于加密。如果敏感信息用Base64编码加密了，赶紧提bug。
经过今天的学习，希望大家有所收获。
如果你喜欢今天的内容，欢迎点赞，关注。
㈡ 如何用base64算法在VB上实现对text1加密
建立两个text文本框，第一个text1作为加密内容，第二个text2作为加密后的内容则text2.text=base64encode（text1.text）
㈢ VB加密解密，急！！
<%
'----加密/解密 函数------
%>
<%
dim sBASE_64_CHARACTERS,varchar,varasc
dim len1
dim i
dim m3
sBASE_64_CHARACTERS = "+/"
sBASE_64_CHARACTERS = strUnicode2Ansi(sBASE_64_CHARACTERS)
Function strUnicodeLen(asContents)
'计算unicode字符串的Ansi编码的长度
asContents1="a"&asContents
len1=len(asContents1)
k=0
for i=1 to len1
asc1=asc(mid(asContents1,i,1))
if asc1<0 then asc1=65536+asc1
if asc1>255 then
k=k+2
else
k=k+1
end if
next
strUnicodeLen=k-1
End Function
Function strUnicode2Ansi(asContents)
'将Unicode编码的字符串，转换成Ansi编码的字符串
strUnicode2Ansi=""
len1=len(asContents)
for i=1 to len1
varchar=mid(asContents,i,1)
varasc=asc(varchar)
if varasc<0 then varasc=varasc+65536
if varasc>255 then
varHex=Hex(varasc)
varlow=left(varHex,2)
varhigh=right(varHex,2)
strUnicode2Ansi=strUnicode2Ansi & chrb("&H" & varlow ) & chrb("&H" & varhigh )
else
strUnicode2Ansi=strUnicode2Ansi & chrb(varasc)
end if
next
End function
Function strAnsi2Unicode(asContents)
'将Ansi编码的字符串，转换成Unicode编码的字符串
strAnsi2Unicode = ""
len1=lenb(asContents)
if len1=0 then exit function
for i=1 to len1
varchar=midb(asContents,i,1)
varasc=ascb(varchar)
if varasc > 127 then
strAnsi2Unicode = strAnsi2Unicode & chr(ascw(midb(asContents,i+1,1) & varchar))
i=i+1
else
strAnsi2Unicode = strAnsi2Unicode & chr(varasc)
end if
next
End function
Function Base64encode(asContents)
'将Ansi编码的字符串进行Base64编码
'asContents应当是ANSI编码的字符串（二进制的字符串也可以）
Dim lnPosition
Dim lsResult
Dim Char1
Dim Char2
Dim Char3
Dim Char4
Dim Byte1
Dim Byte2
Dim Byte3
Dim SaveBits1
Dim SaveBits2
Dim lsGroupBinary
Dim lsGroup64
Dim m4,len1,len2
len1=Lenb(asContents)
if len1<1 then
Base64encode=""
exit Function
end if
m3=Len1 Mod 3
If M3 > 0 Then asContents = asContents & String(3-M3, chrb(0))
IF m3 > 0 THEN
len1=len1+(3-m3)
len2=len1-3
else
len2=len1
end if
lsResult = ""
For lnPosition = 1 To len2 Step 3
lsGroup64 = ""
lsGroupBinary = Midb(asContents, lnPosition, 3)
Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3
Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15
Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))
Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)
Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)
Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)
Char4 = Midb(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)
lsGroup64 = Char1 & Char2 & Char3 & Char4
lsResult = lsResult & lsGroup64
Next
if M3 > 0 then
lsGroup64 = ""
lsGroupBinary = Midb(asContents, len2+1, 3)
Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3
Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15
Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))
Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)
Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)
Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)
if M3=1 then
lsGroup64 = Char1 & Char2 & ChrB(61) & ChrB(61)
else
lsGroup64 = Char1 & Char2 & Char3 & ChrB(61)
end if
lsResult = lsResult & lsGroup64
end if
Base64encode = lsResult
End Function
Function Base64decode(asContents)
'将Base64编码字符串转换成Ansi编码的字符串
'asContents应当也是ANSI编码的字符串（二进制的字符串也可以）
Dim lsResult
Dim lnPosition
Dim lsGroup64, lsGroupBinary
Dim Char1, Char2, Char3, Char4
Dim Byte1, Byte2, Byte3
Dim M4,len1,len2
len1= Lenb(asContents)
M4 = len1 Mod 4
if len1 < 1 or M4 > 0 then
Base64decode = ""
exit Function
end if
if midb(asContents, len1, 1) = chrb(61) then m4=3
if midb(asContents, len1-1, 1) = chrb(61) then m4=2
if m4 = 0 then
len2=len1
else
len2=len1-4
end if
For lnPosition = 1 To Len2 Step 4
lsGroupBinary = ""
lsGroup64 = Midb(asContents, lnPosition, 4)
Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1
Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1
Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1
Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1
Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)
Byte2 = lsGroupBinary & Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)
Byte3 = Chrb((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))
lsGroupBinary = Byte1 & Byte2 & Byte3
lsResult = lsResult & lsGroupBinary
Next
'处理最后剩余的几个字符
if M4 > 0 then
lsGroupBinary = ""
lsGroup64 = Midb(asContents, len2+1, m4) & chrB(65) 'chr(65)=A，转换成值为0
if M4=2 then '补足4位，是为了便于计算
lsGroup64 = lsGroup64 & chrB(65)
end if
Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1
Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1
Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1
Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1
Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)
Byte2 = lsGroupBinary & Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)
Byte3 = Chrb((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))
if M4=2 then
lsGroupBinary = Byte1
elseif M4=3 then
lsGroupBinary = Byte1 & Byte2
end if
lsResult = lsResult & lsGroupBinary
end if
Base64decode = lsResult
End Function
'------------------------------------------------------------------
Function Base64EncodeStr(tpStr)
Base64EncodeStr=strAnsi2Unicode(Base64encode(strUnicode2Ansi(tpStr)))
End Function
Function Base64DecodeStr(tpStr)
Base64DecodeStr=strAnsi2Unicode(Base64decode(strUnicode2Ansi(tpStr)))
End Function
%>
<%
'可用于加密一串地址,多个字符串
A_Key=split("96,44,63,80",",") '定义密钥
'*********加密的过程*********
Function EnCrypt(m)
Dim strChar,iKeyChar,iStringChar,I
k=0
for I = 1 to Len(m)
iKeyChar =Cint(A_Key(k))
iStringChar = Asc(mid(m,I,1)) '获取字符的ASCII码值
iCryptChar = iKeyChar Xor iStringChar '进行异或运算
'对密钥进行移位运算
If k<3 Then
k=k+1
Else
k=0
End If
c = c & Chr(iCryptChar)
next
EnCrypt = c
End Function
'*********解密的过程*********
Function DeCrypt(c)
Dim strChar, iKeyChar, iStringChar, I
k=0
for I = 1 to Len(c)
iKeyChar =Cint(A_Key(k))
iStringChar = Asc(mid(c,I,1))
iDeCryptChar = iKeyChar Xor iStringChar '进行异或运算
'对密钥进行移位运算
If k<3 Then
k=k+1
Else
k=0
End If
strDecrypted = strDecrypted & Chr(iDeCryptChar)
next
DeCrypt = strDecrypted
End Function
'中文 可以！但要将所有 Asc() 函数换成 AscW() 函数, Chr() 函数换成 ChrW() 函数！
%>
<%
'-----------------------------------------------------------------
'简单加密解密
'加密：
'适用于任何字符，包括空格和url冲突的"&""?""%"汉字等符号
'简单加密，可以改造成移位加密，比如每个字符asc码值增加或减少一个数字
'可以改造成移位随机加密。
'比如每个字符前有一个随机数字，表示该字符asc码值增加或减少这个随机数字
'-----------------------------------------------------------------
Function Smp_Encode(x) '加密
for i=1 to len(x)
TempNum=hex(asc(mid(x,i,1)))
if len(TempNum)=4 then
Smp_Encode=Smp_Encode & cstr(TempNum)
else
Smp_Encode=Smp_Encode & "00" & cstr(TempNum)
end if
next
End Function
Function Smp_Decode(x) '解密
for i=1 to len(x) step 4
Smp_Decode=Smp_Decode & chr(int("&H" & mid(x,i,4)))
next
End Function
%>
<%
Function S_Encode(str) '加密字符串
'str = EnCrypt(str)
'str = Base64EncodeStr(str)
str = Smp_Encode(str)
S_Encode = str
End Function
Function S_Decode(str) '解密字符串
'str = DeCrypt(str)
'str = Base64DecodeStr(str)
str = Smp_Decode(str)
S_Decode = str
End Function
%>
<%
Dim theFStr,theEStr,theLStr,IfReal
theFStr = "#$%&'()*+,.-_/:;<=>?@[\\]^`{|}~%中文" '原始字符串
theEStr = Str_Encode(theFStr) '加密字符串
theLStr = Str_Decode(theEStr) '还原字符串
If theFStr=theLStr Then
IfReal = True
Else
IfReal = False
End If
Response.Write "加密前为:"& theFStr &"<BR>"&VbCrlf
Response.Write "加密前字符长度:"& Len(theFStr) &"<BR><BR>"
Response.Write "加密后为:"& theEStr &"<BR>"&VbCrlf
Response.Write "加密后的字符长度:"& Len(theEStr) &"<BR><BR>"
Response.Write "解密(还原)后为:" & theLStr &"<BR>"&VbCrlf
Response.Write "前后字符是否相等:" & IfReal &"<BR>"&VbCrlf
%>
㈣ vb qq密码加密问题
全部代码如下：
一个form，3个text，一个command
Private m_lOnBits(30)
Private m_l2Power(30)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Function Hex2Bin(HexStr1 As String)
Select Case UCase(HexStr1)
Case "0"
q1 = "0000"
Case "1"
q1 = "0001"
Case "2"
q1 = "0010"
Case "3"
q1 = "0011"
Case "4"
q1 = "0100"
Case "5"
q1 = "0101"
Case "6"
q1 = "0110"
Case "7"
q1 = "0111"
Case "8"
q1 = "1000"
Case "9"
q1 = "1001"
Case "A"
q1 = "1010"
Case "B"
q1 = "1011"
Case "C"
q1 = "1100"
Case "D"
q1 = "1101"
Case "E"
q1 = "1110"
Case "F"
q1 = "1111"
End Select
Hex2Bin = q1
End Function
Function Hex2Bin1(HexStr2 As String)
q1 = Hex2Bin(Mid(HexStr2, 1, 1))
q2 = Hex2Bin(Mid(HexStr2, 2, 1))
q3 = Hex2Bin(Mid(HexStr2, 3, 1))
q4 = Hex2Bin(Mid(HexStr2, 4, 1))
q5 = Hex2Bin(Mid(HexStr2, 5, 1))
q6 = Hex2Bin(Mid(HexStr2, 6, 1))
q7 = Hex2Bin(Mid(HexStr2, 7, 1))
q8 = Hex2Bin(Mid(HexStr2, 8, 1))
q9 = Hex2Bin(Mid(HexStr2, 9, 1))
q10 = Hex2Bin(Mid(HexStr2, 10, 1))
q11 = Hex2Bin(Mid(HexStr2, 11, 1))
q12 = Hex2Bin(Mid(HexStr2, 12, 1))
Hex2Bin1 = q1 & q2 & q3 & q4 & q5 & q6 & q7 & q8 & q9 & q10 & q11 & q12
End Function
Function Bin324(BinCode1 As String)
q1 = Mid(BinCode1, 1, 6)
q2 = Mid(BinCode1, 7, 6)
q3 = Mid(BinCode1, 13, 6)
q4 = Mid(BinCode1, 19, 6)
q5 = Mid(BinCode1, 25, 6)
q6 = Mid(BinCode1, 31, 6)
q7 = Mid(BinCode1, 37, 6)
q8 = Mid(BinCode1, 43, 6)
Bin324 = "00" & q1 & "00" & q2 & "00" & q3 & "00" & q4 & "00" & q5 & "00" & q6 & "00" & q7 & "00" & q8
End Function
Function Bin2Hex(BinCode2 As String)
Select Case UCase(BinCode2)
Case "0000"
q1 = "0"
Case "0001"
q1 = "1"
Case "0010"
q1 = "2"
Case "0011"
q1 = "3"
Case "0100"
q1 = "4"
Case "0101"
q1 = "5"
Case "0110"
q1 = "6"
Case "0111"
q1 = "7"
Case "1000"
q1 = "8"
Case "1001"
q1 = "9"
Case "1010"
q1 = "A"
Case "1011"
q1 = "B"
Case "1100"
q1 = "C"
Case "1101"
q1 = "D"
Case "1110"
q1 = "E"
Case "1111"
q1 = "F"
End Select
Bin2Hex = q1
End Function
Function Bin2Hex2(BinCode As String)
q1 = Bin2Hex(Mid(BinCode, 1, 4))
q2 = Bin2Hex(Mid(BinCode, 5, 4))
q3 = Bin2Hex(Mid(BinCode, 9, 4))
q4 = Bin2Hex(Mid(BinCode, 13, 4))
Bin2Hex2 = q1 & q2 & q3 & q4
End Function
Function Bin2Hex3(BinCode3 As String)
q1 = Bin2Hex2(Mid(BinCode3, 1, 16))
q2 = Bin2Hex2(Mid(BinCode3, 17, 16))
q3 = Bin2Hex2(Mid(BinCode3, 33, 16))
q4 = Bin2Hex2(Mid(BinCode3, 49, 16))
Bin2Hex3 = q1 & q2 & q3 & q4
End Function
Function HexBase64(HexString As String)
HexBase64 = HexBase64_2(Bin2Hex3(Bin324(Hex2Bin1(HexString))))
End Function
Function HexBase64_1(HexString As String)
Select Case HexString
Case "00"
q1 = "A"
Case "01"
q1 = "B"
Case "02"
q1 = "C"
Case "03"
q1 = "D"
Case "04"
q1 = "E"
Case "05"
q1 = "F"
Case "06"
q1 = "G"
Case "07"
q1 = "H"
Case "08"
q1 = "I"
Case "09"
q1 = "J"
Case "0A"
q1 = "K"
Case "0B"
q1 = "L"
Case "0C"
q1 = "M"
Case "0D"
q1 = "N"
Case "0E"
q1 = "O"
Case "0F"
q1 = "P"
Case "10"
q1 = "Q"
Case "11"
q1 = "R"
Case "12"
q1 = "S"
Case "13"
q1 = "T"
Case "14"
q1 = "U"
Case "15"
q1 = "V"
Case "16"
q1 = "W"
Case "17"
q1 = "X"
Case "18"
q1 = "Y"
Case "19"
q1 = "Z"
Case "1A"
q1 = "a"
Case "1B"
q1 = "b"
Case "1C"
q1 = "c"
Case "1D"
q1 = "d"
Case "1E"
q1 = "e"
Case "1F"
q1 = "f"
Case "20"
q1 = "g"
Case "21"
q1 = "h"
Case "22"
q1 = "i"
Case "23"
q1 = "j"
Case "24"
q1 = "k"
Case "25"
q1 = "l"
Case "26"
q1 = "m"
Case "27"
q1 = "n"
Case "28"
q1 = "o"
Case "29"
q1 = "p"
Case "2A"
q1 = "q"
Case "2B"
q1 = "r"
Case "2C"
q1 = "s"
Case "2D"
q1 = "t"
Case "2E"
q1 = "u"
Case "2F"
q1 = "v"
Case "30"
q1 = "w"
Case "31"
q1 = "x"
Case "32"
q1 = "y"
Case "33"
q1 = "z"
Case "34"
q1 = "0"
Case "35"
q1 = "1"
Case "36"
q1 = "2"
Case "37"
q1 = "3"
Case "38"
q1 = "4"
Case "39"
q1 = "5"
Case "3A"
q1 = "6"
Case "3B"
q1 = "7"
Case "3C"
q1 = "8"
Case "3D"
q1 = "9"
Case "3E"
q1 = "+"
Case "3F"
q1 = "/"
End Select
HexBase64_1 = q1
End Function
Function HexBase64_2(HexString As String)
q1 = HexBase64_1(Mid(HexString, 1, 2))
q2 = HexBase64_1(Mid(HexString, 3, 2))
q3 = HexBase64_1(Mid(HexString, 5, 2))
q4 = HexBase64_1(Mid(HexString, 7, 2))
q5 = HexBase64_1(Mid(HexString, 9, 2))
q6 = HexBase64_1(Mid(HexString, 11, 2))
q7 = HexBase64_1(Mid(HexString, 13, 2))
q8 = HexBase64_1(Mid(HexString, 15, 2))
HexBase64_2 = q1 & q2 & q3 & q4 & q5 & q6 & q7 & q8
End Function
Function Hex2Base64(HexCode As String)
For i = 0 To Len(HexCode) Step 12
q1 = q1 & HexBase64(Mid(HexCode, i + 1, 12))
Next
Hex2Base64 = q1
End Function
Private Function md5_F(X, Y, z)
md5_F = (X And Y) Or ((Not X) And z)
End Function
Private Function md5_G(X, Y, z)
md5_G = (X And z) Or (Y And (Not z))
End Function
Private Function md5_H(X, Y, z)
md5_H = (X Xor Y Xor z)
End Function
Private Function md5_I(X, Y, z)
md5_I = (Y Xor (X Or (Not z)))
End Function
Private Sub md5_FF(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_GG(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_HH(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_II(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage, stype)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
Dim X
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
X = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(X) Step 16
AA = a
BB = b
CC = c
DD = d
md5_FF a, b, c, d, X(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, X(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, X(k + 2), S13, &H242070DB
md5_FF b, c, d, a, X(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, X(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, X(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, X(k + 6), S13, &HA8304613
md5_FF b, c, d, a, X(k + 7), S14, &HFD469501
md5_FF a, b, c, d, X(k + 8), S11, &H698098D8
md5_FF d, a, b, c, X(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, X(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, X(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, X(k + 12), S11, &H6B901122
md5_FF d, a, b, c, X(k + 13), S12, &HFD987193
md5_FF c, d, a, b, X(k + 14), S13, &HA679438E
md5_FF b, c, d, a, X(k + 15), S14, &H49B40821
md5_GG a, b, c, d, X(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, X(k + 6), S22, &HC040B340
md5_GG c, d, a, b, X(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, X(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, X(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, X(k + 10), S22, &H2441453
md5_GG c, d, a, b, X(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, X(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, X(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, X(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, X(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, X(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, X(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, X(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, X(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, X(k + 12), S24, &H8D2A4C8A
md5_HH a, b, c, d, X(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, X(k + 8), S32, &H8771F681
md5_HH c, d, a, b, X(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, X(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, X(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, X(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, X(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, X(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, X(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, X(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, X(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, X(k + 6), S34, &H4881D05
md5_HH a, b, c, d, X(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, X(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, X(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, X(k + 2), S34, &HC4AC5665
md5_II a, b, c, d, X(k + 0), S41, &HF4292244
md5_II d, a, b, c, X(k + 7), S42, &H432AFF97
md5_II c, d, a, b, X(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, X(k + 5), S44, &HFC93A039
md5_II a, b, c, d, X(k + 12), S41, &H655B59C3
md5_II d, a, b, c, X(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, X(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, X(k + 1), S44, &H85845DD1
md5_II a, b, c, d, X(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, X(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, X(k + 6), S43, &HA3014314
md5_II b, c, d, a, X(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, X(k + 4), S41, &HF7537E82
md5_II d, a, b, c, X(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, X(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, X(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
If stype = 32 Then
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
Else
MD5 = LCase(WordToHex(b) & WordToHex(c))
End If
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Public Function Str2QQPwdHash(Str1 As String)
Str2QQPwdHash = Hex2Base64(MD5(Str1, 32)) & "=="
End Function
'Private Sub Form_Load()
'Dim QQPath, QQNum, QQPass
'QQPath = "E:\聊天工具\QQ\QQ.exe" 'QQ所在路径
'QQNum = "100000" 'QQ号码
'QQPass = "阿苏达三" 'QQ密码
'Shell QQPath & " /START QQUIN:" & QQNum & " PWDHASH:" & Str2QQPwdHash(Trim(QQPass)) & " /STAT:40" '在线为41，隐身为40
'End '不想form退出,此处的end删除或加'
'End Sub
'如果想运行程序就登陆的话，不要下面的command1的代码，将formload代码前的 ' 全部去掉~
'写在最后，QQNum = "QQ号码" 和 QQPass = "QQ密码" 你可以用如下来代替~放在 command1 中,并将formload全部删除，如下:
Private Sub Command1_Click()
Dim QQPath, QQNum, QQPass
QQPath = Text1.Text 'QQ所在路径
QQNum = Text2.Text 'QQ号码
QQPass = Text3.Text 'QQ密码
Shell QQPath & " /START QQUIN:" & QQNum & " PWDHASH:" & Str2QQPwdHash(Trim(QQPass)) & " /STAT:40" '在线为41，隐身为40
End Sub
㈤ vb怎样加密明文
MD5 或者Base64 加密。
下面是两个加密方法的代码，
建个模块把下面代码放进去。
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'% %
'% -------------- MD5 加密模块 ---------------- %
'% ------------- Base64编码模块 --------------- %
'% %
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Private m_lOnBits(30)
Private m_l2Power(30)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Function Hex2Bin(HexStr1 As String)
Select Case UCase(HexStr1)
'16进制转换二进制
Case "0"
q1 = "0000"
Case "1"
q1 = "0001"
Case "2"
q1 = "0010"
Case "3"
q1 = "0011"
Case "4"
q1 = "0100"
Case "5"
q1 = "0101"
Case "6"
q1 = "0110"
Case "7"
q1 = "0111"
Case "8"
q1 = "1000"
Case "9"
q1 = "1001"
Case "A"
q1 = "1010"
Case "B"
q1 = "1011"
Case "C"
q1 = "1100"
Case "D"
q1 = "1101"
Case "E"
q1 = "1110"
Case "F"
q1 = "1111"
End Select
Hex2Bin = q1
End Function
Function Hex2Bin1(HexStr2 As String)
'分断
q1 = Hex2Bin(Mid(HexStr2, 1, 1))
q2 = Hex2Bin(Mid(HexStr2, 2, 1))
q3 = Hex2Bin(Mid(HexStr2, 3, 1))
q4 = Hex2Bin(Mid(HexStr2, 4, 1))
q5 = Hex2Bin(Mid(HexStr2, 5, 1))
q6 = Hex2Bin(Mid(HexStr2, 6, 1))
q7 = Hex2Bin(Mid(HexStr2, 7, 1))
q8 = Hex2Bin(Mid(HexStr2, 8, 1))
q9 = Hex2Bin(Mid(HexStr2, 9, 1))
q10 = Hex2Bin(Mid(HexStr2, 10, 1))
q11 = Hex2Bin(Mid(HexStr2, 11, 1))
q12 = Hex2Bin(Mid(HexStr2, 12, 1))
Hex2Bin1 = q1 & q2 & q3 & q4 & q5 & q6 & q7 & q8 & q9 & q10 & q11 & q12
End Function
Function Bin324(BinCode1 As String)
'填充
q1 = Mid(BinCode1, 1, 6)
q2 = Mid(BinCode1, 7, 6)
q3 = Mid(BinCode1, 13, 6)
q4 = Mid(BinCode1, 19, 6)
q5 = Mid(BinCode1, 25, 6)
q6 = Mid(BinCode1, 31, 6)
q7 = Mid(BinCode1, 37, 6)
q8 = Mid(BinCode1, 43, 6)
Bin324 = "00" & q1 & "00" & q2 & "00" & q3 & "00" & q4 & "00" & q5 & "00" & q6 & "00" & q7 & "00" & q8
End Function
Function Bin2Hex(BinCode2 As String)
'二进制转换为16进制（BASE64一部分）
Select Case UCase(BinCode2)
Case "0000"
q1 = "0"
Case "0001"
q1 = "1"
Case "0010"
q1 = "2"
Case "0011"
q1 = "3"
Case "0100"
q1 = "4"
Case "0101"
q1 = "5"
Case "0110"
q1 = "6"
Case "0111"
q1 = "7"
Case "1000"
q1 = "8"
Case "1001"
q1 = "9"
Case "1010"
q1 = "A"
Case "1011"
q1 = "B"
Case "1100"
q1 = "C"
Case "1101"
q1 = "D"
Case "1110"
q1 = "E"
Case "1111"
q1 = "F"
End Select
Bin2Hex = q1
End Function
Function Bin2Hex2(BinCode As String)
q1 = Bin2Hex(Mid(BinCode, 1, 4))
q2 = Bin2Hex(Mid(BinCode, 5, 4))
q3 = Bin2Hex(Mid(BinCode, 9, 4))
q4 = Bin2Hex(Mid(BinCode, 13, 4))
Bin2Hex2 = q1 & q2 & q3 & q4
End Function
Function Bin2Hex3(BinCode3 As String)
q1 = Bin2Hex2(Mid(BinCode3, 1, 16))
q2 = Bin2Hex2(Mid(BinCode3, 17, 16))
q3 = Bin2Hex2(Mid(BinCode3, 33, 16))
q4 = Bin2Hex2(Mid(BinCode3, 49, 16))
Bin2Hex3 = q1 & q2 & q3 & q4
End Function
Function HexBase64(HexString As String)
HexBase64 = HexBase64_2(Bin2Hex3(Bin324(Hex2Bin1(HexString))))
End Function
Function HexBase64_1(HexString As String)
Select Case HexString
Case "00"
q1 = "A"
Case "01"
q1 = "B"
Case "02"
q1 = "C"
Case "03"
q1 = "D"
Case "04"
q1 = "E"
Case "05"
q1 = "F"
Case "06"
q1 = "G"
Case "07"
q1 = "H"
Case "08"
q1 = "I"
Case "09"
q1 = "J"
Case "0A"
q1 = "K"
Case "0B"
q1 = "L"
Case "0C"
q1 = "M"
Case "0D"
q1 = "N"
Case "0E"
q1 = "O"
Case "0F"
q1 = "P"
Case "10"
q1 = "Q"
Case "11"
q1 = "R"
Case "12"
q1 = "S"
Case "13"
q1 = "T"
Case "14"
q1 = "U"
Case "15"
q1 = "V"
Case "16"
q1 = "W"
Case "17"
q1 = "X"
Case "18"
q1 = "Y"
Case "19"
q1 = "Z"
Case "1A"
q1 = "a"
Case "1B"
q1 = "b"
Case "1C"
q1 = "c"
Case "1D"
q1 = "d"
Case "1E"
q1 = "e"
Case "1F"
q1 = "f"
Case "20"
q1 = "g"
Case "21"
q1 = "h"
Case "22"
q1 = "i"
Case "23"
q1 = "j"
Case "24"
q1 = "k"
Case "25"
q1 = "l"
Case "26"
q1 = "m"
Case "27"
q1 = "n"
Case "28"
q1 = "o"
Case "29"
q1 = "p"
Case "2A"
q1 = "q"
Case "2B"
q1 = "r"
Case "2C"
q1 = "s"
Case "2D"
q1 = "t"
Case "2E"
q1 = "u"
Case "2F"
q1 = "v"
Case "30"
q1 = "w"
Case "31"
q1 = "x"
Case "32"
q1 = "y"
Case "33"
q1 = "z"
Case "34"
q1 = "0"
Case "35"
q1 = "1"
Case "36"
q1 = "2"
Case "37"
q1 = "3"
Case "38"
q1 = "4"
Case "39"
q1 = "5"
Case "3A"
q1 = "6"
Case "3B"
q1 = "7"
Case "3C"
q1 = "8"
Case "3D"
q1 = "9"
Case "3E"
q1 = "+"
Case "3F"
q1 = "/"
End Select
HexBase64_1 = q1
End Function
Function HexBase64_2(HexString As String)
q1 = HexBase64_1(Mid(HexString, 1, 2))
q2 = HexBase64_1(Mid(HexString, 3, 2))
q3 = HexBase64_1(Mid(HexString, 5, 2))
q4 = HexBase64_1(Mid(HexString, 7, 2))
q5 = HexBase64_1(Mid(HexString, 9, 2))
q6 = HexBase64_1(Mid(HexString, 11, 2))
q7 = HexBase64_1(Mid(HexString, 13, 2))
q8 = HexBase64_1(Mid(HexString, 15, 2))
HexBase64_2 = q1 & q2 & q3 & q4 & q5 & q6 & q7 & q8
End Function
Function Hex2Base64(HexCode As String)
For i = 0 To Len(HexCode) Step 12
q1 = q1 & HexBase64(Mid(HexCode, i + 1, 12))
Next
Hex2Base64 = q1
End Function
Private Function md5_F(x, y, z)
md5_F = (x And y) Or ((Not x) And z)
End Function
Private Function md5_G(x, y, z)
md5_G = (x And z) Or (y And (Not z))
End Function
Private Function md5_H(x, y, z)
md5_H = (x Xor y Xor z)
End Function
Private Function md5_I(x, y, z)
md5_I = (y Xor (x Or (Not z)))
End Function
Private Sub md5_FF(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_GG(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_HH(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub md5_II(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte
Dim lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Public Function MD5(sMessage, stype)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
Dim x
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
md5_FF a, b, c, d, x(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, x(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, x(k + 2), S13, &H242070DB
md5_FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, x(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, x(k + 6), S13, &HA8304613
md5_FF b, c, d, a, x(k + 7), S14, &HFD469501
md5_FF a, b, c, d, x(k + 8), S11, &H698098D8
md5_FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, x(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, x(k + 12), S11, &H6B901122
md5_FF d, a, b, c, x(k + 13), S12, &HFD987193
md5_FF c, d, a, b, x(k + 14), S13, &HA679438E
md5_FF b, c, d, a, x(k + 15), S14, &H49B40821
md5_GG a, b, c, d, x(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, x(k + 6), S22, &HC040B340
md5_GG c, d, a, b, x(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, x(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, x(k + 10), S22, &H2441453
md5_GG c, d, a, b, x(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, x(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, x(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, x(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, x(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, x(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
md5_HH a, b, c, d, x(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, x(k + 8), S32, &H8771F681
md5_HH c, d, a, b, x(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, x(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, x(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, x(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, x(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, x(k + 6), S34, &H4881D05
md5_HH a, b, c, d, x(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, x(k + 2), S34, &HC4AC5665
md5_II a, b, c, d, x(k + 0), S41, &HF4292244
md5_II d, a, b, c, x(k + 7), S42, &H432AFF97
md5_II c, d, a, b, x(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, x(k + 5), S44, &HFC93A039
md5_II a, b, c, d, x(k + 12), S41, &H655B59C3
md5_II d, a, b, c, x(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, x(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, x(k + 1), S44, &H85845DD1
md5_II a, b, c, d, x(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, x(k + 6), S43, &HA3014314
md5_II b, c, d, a, x(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, x(k + 4), S41, &HF7537E82
md5_II d, a, b, c, x(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
If stype = 32 Then
MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
Else
MD5 = LCase(WordToHex(b) & WordToHex(c))
End If
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Public Function Str2QQPwdHash(Str1 As String)
Str2QQPwdHash = Hex2Base64(MD5(Str1, 32)) & "=="
End Function
㈥ 01加密方式-Base64编码
说明
HTTP将Base64编码用于基本的认证和摘要认证。
其可以方便的将用户的任何输入转换成只包含特定字符的安全格式，服务于网络通信过程。
特点
1）可以将任意的二进制数据进行Base64编码。
2）所有的数据都能被编码为并只用65个字符就能表示的文本文件。
3）编码后的65个字符包括A Z,a z,0~9,+,/,=
4）对文件或字符串进行Base64编码后将比 原始大小增加33% 。
5)能够逆运算
6）不够安全，但却被很多加密算法作为编码方式
1）将所有字符转化为ASCII码；
2）将ASCII码转化为8位二进制；
3）将二进制3个归成一组(不足3个在后边补0)共24位，再拆分成4组，每组6位；
4）统一在6位二进制前补两个0凑足8位；
5）将补0后的二进制转为十进制；
6）从Base64编码表获取十进制对应的Base64编码；
a.转换的时候，将三个byte的数据，先后放入一个24bit的缓冲区中，先来的byte占高位。
b.数据不足3byte的话，则剩下的bit用0补足。每次取出6个bit，按照其值选择查表选择对应的字符作为编码后的输出。
c.不断进行，直到全部输入数据转换完成。
d.如果最后剩下两个输入数据，在编码结果后加1个“=”；
e.如果最后剩下一个输入数据，编码结果后加2个“=”；
f.如果没有剩下任何数据，就什么都不要加，这样才可以保证资料还原的正确性。
运行效果图
㈦ 伪加密算法：Base64
做过网络通信的iOSer对Base64都不会很陌生，涉及加密的数据通常会在传输之前做一次Base64转换，一般形式如下 Base64(DES/AES(Data)) ，所以有些iOSer就把Base64当作加密算法的一种，甚至一些在线工具也直接称呼Base64为加密/解密，实际上这误会可大了，本篇回答以下三个问题：
要回答第一个问题，首先来看看Base64的编码过程，这里以字符串 “1234” 为例，经过Base64编码后，结果为 "MTIzNA==" ，也是一个字符串，过程如下：
看到这里，你会疑问，这样的编码有什么用？
Base64真正的作用不是将字符串转换为另一个字符串，而是将任意二进制转换为字符串，这个字符串的范围还很小，只有64个，这就为那些只能传输字符串的协议传输数据带来方便，比如http，通过一些字符的替换，还可以避免特殊字符的冲突。
苹果已经提供了原生的API，用Swift做Base64编码：
NSData.Base64EncodingOptions 有四个可选值：
可以组合使用：
编码结果按76个字符换行，换行符为\r。
解码方法如下：
思考题：
编码过程中，6位补8位的规则是什么，是高位补0还是低位，为什么？经过深入思考的结果才是自己的哦，欢迎你的留言👏
㈧ 求教VB6.0关于BASE64加密算法错误问题
Option Explicit
Private Const BASE64CHR As String = "+/="
Private psBase64Chr(0 To 63) As String
'从一个经过Base64的字符串中解码到源字符串
Public Function DecodeBase64String(str2Decode As String) As String
DecodeBase64String = StrConv(DecodeBase64Byte(str2Decode), vbUnicode)
End Function
'从一个经过Base64的字符串中解码到源字节数组
Public Function DecodeBase64Byte(str2Decode As String) As Byte()
Dim lPtr As Long
Dim iValue As Integer
Dim iLen As Integer
Dim iCtr As Integer
Dim Bits(1 To 4) As Byte
Dim strDecode As String
Dim str As String
Dim Output() As Byte
Dim iIndex As Long
Dim lFrom As Long
Dim lTo As Long
InitBase
'//除去回车
str = Replace(str2Decode, vbCrLf, "")
'//每4个字符一组（4个字符表示3个字）
For lPtr = 1 To Len(str) Step 4
iLen = 4
For iCtr = 0 To 3
'//查找字符在BASE64字符串中的位置
iValue = InStr(1, BASE64CHR, Mid$(str, lPtr + iCtr, 1), vbBinaryCompare)
Select Case iValue 'A~Za~z0~9+/
Case 1 To 64:
Bits(iCtr + 1) = iValue - 1
Case 65 '=
iLen = iCtr
Exit For
'//没有发现
Case 0: Exit Function
End Select
Next
'//转换4个6比特数成为3个8比特数
Bits(1) = Bits(1) * &H4 + (Bits(2) And &H30) \ &H10
Bits(2) = (Bits(2) And &HF) * &H10 + (Bits(3) And &H3C) \ &H4
Bits(3) = (Bits(3) And &H3) * &H40 + Bits(4)
'//计算数组的起始位置
lFrom = lTo
lTo = lTo + (iLen - 1) - 1
'//重新定义输出数组
ReDim Preserve Output(0 To lTo)
For iIndex = lFrom To lTo
Output(iIndex) = Bits(iIndex - lFrom + 1)
Next
lTo = lTo + 1
Next
DecodeBase64Byte = Output
End Function
'将一个Base64字符串解码，并写入二进制文件
Public Sub DecodeBase64StringToFile(strBase64 As String, strFilePath As String)
Dim fso As New Scripting.FileSystemObject, _
i As Long
If fso.FileExists(strFilePath) Then
fso.DeleteFile strFilePath, True
End If
i = FreeFile
Open strFilePath For Binary Access Write As i
Put i, , DecodeBase64Byte(strBase64)
Close i
Set fso = Nothing
End Sub
'将一个Base64编码文件解码，并写入二进制文件
Public Sub DecodeBase64FileToFile(strBase64FilePath As String, strFilePath As String)
Dim fso As New Scripting.FileSystemObject
Dim ts As TextStream
If Not fso.FileExists(strBase64FilePath) Then Exit Sub
Set ts = fso.OpenTextFile(strBase64FilePath)
DecodeBase64StringToFile ts.ReadAll, strFilePath
End Sub
'将一个字节数组进行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
'//转换字符串为数组，然后转换为4个6位(0-63)
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
'//添加4个新字符
For lPtr = 1 To lLen + 1
sEncoded = sEncoded & psBase64Chr(Bits6(lPtr))
Next
Next
'//不足4位，以=填充
Select Case lLen + 1
Case 2: sEncoded = sEncoded & "=="
Case 3: sEncoded = sEncoded & "="
Case 4:
End Select
EncodeBase64Byte = sEncoded
End Function
'对字符串进行Base64编码并返回字符串
Public Function EncodeBase64String(str2Encode As String) As String
Dim sValue() As Byte
sValue = StrConv(str2Encode, vbFromUnicode)
EncodeBase64String = EncodeBase64Byte(sValue)
End Function
'对文件进行Base64编码并返回编码后的Base64字符串
Public Function EncodFileToBase64String(strFileSource As String)
Dim lpdata() As Byte, _
i As Long, _
n As Long, _
fso As New Scripting.FileSystemObject
If Not fso.FileExists(strFileSource) Then Exit Function
i = FreeFile
Open strFileSource For Binary Access Read Lock Write As i
n = LOF(i) - 1
ReDim lpdata(0 To n)
Get i, , lpdata
Close i
EncodFileToBase64String = EncodeBase64Byte(lpdata)
End Function
'对文件进行Base64编码，并将编码后的内容直接写入一个文本文件中
Public Sub EncodFileToBase64File(strFileSource As String, strFileBase64Desti As String)
Dim fso As New FileSystemObject, _
ts As TextStream
Set ts = fso.CreateTextFile(strFileBase64Desti, True)
ts.Write (EncodFileToBase64String(strFileSource))
ts.Close
Set ts = Nothing
Set fso = Nothing
End Sub
Private Sub InitBase()
Dim iPtr As Integer
'初始化 BASE64数组
For iPtr = 0 To 63
psBase64Chr(iPtr) = Mid$(BASE64CHR, iPtr + 1, 1)
Next
End Sub