Loading... *应该只能适用于英文、数字等，中文估计不行* > 用法：vbsBase64Encode(StringToByteArray(cstr(需要加密或解密的变量或字符))) ~~~vbnet 'base64加密解密编码 '加密编码 Function vbsBase64Encode(byteArray) Dim last2byte : last2byte = 3 Dim last4byte : last4byte = 15 Dim last6byte : last6byte = 63 Dim lead6byte : lead6byte = 252 Dim lead4byte : lead4byte = 240 Dim lead2byte : lead2byte = 192 Dim encodeTable : encodeTable = Split("A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z,a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,0,1,2,3,4,5,6,7,8,9,+,/", ",") Dim objectStr : objectStr = "" Dim num num = 0 Dim currentByte currentByte = 0 Dim i For i = 0 to ubound(byteArray) num = num mod 8 do while(num < 8) Select Case num Case 0 currentByte = byteArray(i) and lead6byte currentByte = uRShift(currentByte, 2) Case 2 currentByte = byteArray(i) and last6byte Case 4 currentByte = byteArray(i) and last4byte currentByte = LShift(currentByte, 2) If ((i + 1) <= ubound(byteArray)) Then currentByte = currentByte or uRShift(byteArray(i + 1) and lead2byte, 6) End If Case 6 currentByte = byteArray(i) and last2byte currentByte = LShift(currentByte, 4) If ((i + 1) <= ubound(byteArray)) Then currentByte = currentByte or uRShift(byteArray(i + 1) and lead4byte, 4) End If End Select objectStr = objectStr & encodeTable(currentByte) num = num + 6 Loop Next If (Len(objectStr) mod 4 <> 0) Then For i = (4 - Len(objectStr) mod 4) to 1 step - 1 objectStr = objectStr & "=" Next End If vbsBase64Encode = objectStr End Function '解码 Function vbsBase64Decode(str) Dim delta Dim ALPHABET : ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" If Right(str, 2) = "==" Then delta = 2 ElseIf Right(str, 1) = "=" Then delta = 1 Else delta = 0 End If Redim buffer(Len(str) * 3 / 4 - delta) Dim mask : mask = &HFF Dim index : index =0 Dim i, c0, c1, c2, c3 For i = 1 to Len(str) step 4 c0 = Instr(ALPHABET, mid(str, i, 1)) - 1 c1 = Instr(ALPHABET, mid(str, i + 1, 1)) - 1 buffer(index) = (LShift(c0, 2) or RShift(c1, 4)) and mask If buffer(index)>127 Then buffer(index) = buffer(index) - 256 End If index = index + 1 If(index >= ubound(buffer)) Then Exit For End If c2 = Instr(ALPHABET, mid(str, i + 2, 1)) - 1 buffer(index) = (LShift(c1, 4) or RShift(c2, 2)) and mask If buffer(index)>127 Then buffer(index) = buffer(index) - 256 End If index = index + 1 If(index >= ubound(buffer)) Then Exit For End If c3 = Instr(ALPHABET, mid(str, i + 3, 1)) - 1 buffer(index) = (LShift(c2, 6) or c3) and mask If buffer(index)>127 Then buffer(index) = buffer(index) - 256 End If index = index + 1 Next vbsBase64Decode = buffer End Function Function LShift(Value, Shift) Dim sc Set sc = CreateObject("MSScriptControl.ScriptControl") sc.Language = "JScript" LShift = sc.Eval(Value & "<<" & Shift) End Function Function RShift(Value, Shift) Dim sc Set sc = CreateObject("MSScriptControl.ScriptControl") sc.Language = "JScript" RShift = sc.Eval(Value & ">>" & Shift) End Function Function uLShift(Value, Shift) Dim sc Set sc = CreateObject("MSScriptControl.ScriptControl") sc.Language = "JScript" uLShift = sc.Eval(Value & "<<<" & Shift) End Function Function uRShift(Value, Shift) Dim sc Set sc = CreateObject("MSScriptControl.ScriptControl") sc.Language = "JScript" uRShift = sc.Eval(Value & ">>>" & Shift) End Function Function ArrayAdd(byteArray1, byteArray2) Dim i, tmpStr tmpStr = "" For i = 0 to ubound(byteArray1) If i>0 Then tmpStr = tmpStr & "," End If tmpStr = tmpStr & byteArray1(i) Next For i = 0 to ubound(byteArray2) tmpStr = tmpStr & "," & byteArray2(i) Next ArrayAdd = Split(tmpStr, ",") End Function 'Bin字符串转数组 Function BinToByteArray(szInput) Dim i, byteArray, wch, nAsc byteArray = "" For i=1 To Len(szInput) wch = Mid(szInput, i, 1) nAsc = AscW(wch) 'Response.write "<BR>wch = " & nAsc If nAsc>127 Then byteArray = byteArray & "," & (nAsc - 256) Else byteArray = byteArray & "," & nAsc End If Next If Left(byteArray, 1) = "," Then byteArray = Right(byteArray, Len(byteArray) - 1) End If BinToByteArray = Split(byteArray, ",") End Function '字符串转数组 Function StringToByteArray(szInput) Dim i, byteArray, wch, nAsc byteArray = "" For i=1 To Len(szInput) wch = Mid(szInput, i, 1) nAsc = AscW(wch) If nAsc < 0 Then nAsc = nAsc + 65536 End If If (nAsc And &HFF80) = 0 Then byteArray = byteArray & "," & AscW(wch) Else If (nAsc And &HF000) = 0 Then byteArray = byteArray & "," & Cint("&H" & Hex(((nAsc \ 2 ^ 6)) Or &HC0)) - 256 & "," & Cint("&H" & Hex(nAsc And &H3F Or &H80))-256 Else byteArray = byteArray & "," & Cint("&H" & Hex((nAsc \ 2 ^ 12) Or &HE0)) - 256 & "," & Cint("&H" & Hex((nAsc \ 2 ^ 6) And &H3F Or &H80)) - 256 & "," & Cint("&H" & Hex(nAsc And &H3F Or &H80)) - 256 End If End If Next If Left(byteArray, 1) = "," Then byteArray = Right(byteArray, Len(byteArray) - 1) End If StringToByteArray = Split(byteArray, ",") End Function Function ByteArrayToString(sArray) Dim i, tStr, byte1, byte2, byte3 tStr = "" For i = 0 to ubound(sArray) If sArray(i)>0 and sArray(i)<128 Then tStr = tStr & Chr(sArray(i)) Else If i < ubound(sArray) - 1 Then byte1 = ((sArray(i) + 256) And &H3F) * &H40 If byte1<2048 Then byte1 = ((sArray(i) + 256) And &H3F) * &H40 byte2 = (sArray(i + 1) + 256) And &H3F tStr = tStr & chrW(byte1 or byte2) i = i + 1 Else byte1 = ((sArray(i) + 256) And &H0F) * &H1000 byte2 = ((sArray(i + 1) + 256) And &H3F) * &H40 byte3 = (sArray(i + 2) + 256) And &H3F tStr = tStr & chrW(byte1 or byte2 or byte3) i = i + 2 End If End If End If Next ByteArrayToString = tStr End Function ~~~ 最后修改：2024 年 04 月 09 日 © 允许规范转载 赞 如果觉得我的文章对你有用，请随意赞赏