Option Public
Option Explicit
Const Power8 = 2 ^ 8
Const Power16 = 2 ^ 16
Const Power6 = 2 ^ 6
Const Power12 = 2 ^ 12
Const Power18 = 2 ^ 18
Const Base64Chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Const Base64ValidChars = Base64Chars & "="
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Lib com.8u8.equalto.Util.Base64
' ---- By FangZeYu(OnceATime@163.com)
' ---- By LuHong(ChongBugLH@163.com)
' ---- 2004-09 BeiJing
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 版权声明:
' 软件可以自由传播修改,亦默认有商业行为允许。
' 但任何时候,请保留原始作者信息。
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 功能列表:
' 函数: Base64Encode: Base64编码
' Base64Eecode: 解码处理
' Base64IsValid:检查是否是一个正确的编码字符串
' GetHexString: 字符串转化为Hex形式
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 修订历史:
' 1、2003年09月,草拟
' 2、2004年09月,整理修订
'
'
'
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function Base64Encode(strDecode As String , asHex As Integer) As String
On Error Goto error_handle
Dim strRet As String
Dim i As Long , Chunk As String , DecNum As Long
Dim lngLen As Long
Dim strT As String
If asHex Then
strT=strDecode
Else
For i=1 To Len(strDecode)
strT=strT & Hex(Asc(Mid(strDecode , i , 1)))
Next
End If
lngLen = Len(strT)
For i=1 To lngLen Step 6
Chunk=Left(Mid(strT , i ,6) & "0000" , 6)
Chunk = Oct$("&H" & Chunk)
strRet=strRet & Mid( Base64Chars , Cint("&O" & Mid(Chunk , 1 ,2 ))+1 ,1)
strRet=strRet & Mid( Base64Chars , Cint("&O" & Mid(Chunk , 3, 2 ))+1 ,1)
Select Case lngLen - i
Case 0:
strRet=strRet & "=="
Case 2:
strRet=strRet & Mid(Base64Chars , Cint("&O" & Mid(Chunk , 5, 2))+1 ,1)
strRet=strRet & "="
Case Else:
strRet=strRet & Mid(Base64Chars , Cint("&O" & Mid(Chunk , 5, 2))+1 ,1)
strRet=strRet & Mid(Base64Chars , Cint("&O" & Mid(Chunk , 7, 2))+1 ,1)
End Select
Next
Base64Encode=strRet
Exit Function
error_handle:
Print "Error In Function Base64Encode On Line " & Erl & " With Code Of " & Err & " Msg Is " Error
Exit Function
End Function
Function Base64Decode(strEncode As String) As String
On Error Goto error_handle
Dim strRet As String
If Base64IsValid(strEncode)=False Then Error 9010 , "错误格式"
Dim i As Long
Dim Chunk As String , DecNum As Long
For i=1 To Len(strEncode) Step 4
Chunk=Mid(strEncode , i ,4)
DecNum = Power18 * (Instr(Base64Chars , Mid (Chunk , 1 , 1))-1)
DecNum = DecNum + Power12 * (Instr(Base64Chars , Mid(Chunk , 2, 1))-1)
If Mid(Chunk , 3 ,1 ) = "=" Then
strRet = strRet & Chr((DecNum / Power16 ) And &HFF )
Elseif Mid(Chunk , 4, 1) = "=" Then
DecNum = DecNum + Power6 * (Instr(Base64Chars , Mid(Chunk , 3 ,1))-1)
strRet = strRet & Chr((DecNum / Power16 ) And &HFF )
strRet = strRet & Chr((DecNum / Power8 ) And &HFF )
Else
DecNum = DecNum + Power6 * (Instr(Base64Chars , Mid(Chunk , 3, 1))-1)
DecNum = DecNum + (Instr(Base64Chars , Mid(Chunk , 4, 1))-1)
strRet = strRet & Chr((DecNum / Power16 ) And &HFF )
strRet = strRet & Chr((DecNum / Power8 ) And &HFF )
strRet = strRet & Chr((DecNum) And &HFF )
End If
Next
Base64Decode=strRet
Exit Function
error_handle:
Print " Error In Function Base64Decode On Line " & Erl & " With Code Of " & Err
Exit Function
End Function
Function Base64IsValid(strEncode As String ) As Integer
Base64IsValid=False
Dim i As Long , lngLen As Long
lngLen = Len(strEncode)
If lngLen=0 Then Exit Function
If lngLen Mod 4 > 0 Then Exit Function
For i=1 To lngLen - 2
If Instr(Base64Chars , Mid(strEncode , i , 1))=0 Then Exit Function
Next
For i= lngLen-1 To lngLen
If Instr(Base64ValidChars , Mid(strEncode , i , 1))=0 Then Exit Function
Next
Base64IsValid=True
End Function
Function GetHexString(str1 As String ) As String
Dim i As Long
Dim strT As String , str2 As String
For i=1 To Len(str1)
str2=Hex(Asc(Mid(str1 , i , 1)))
If Len(str2) > 2 Then
strT=strT+Right("0" & str2 ,4)
Else
strT=strT+Right("0" & str2 ,2)
End If
Next
GetHexString=strT
End Function