Util.Base64.lss

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