明晨网络

电话： 136-6532-7492 QQ: 给我发送消息 8507-0741

VB下的BASE64编码类模块

admin，2009-06-12 18:36， 文章标签: VB BASE64

    这个VB类模块可以用来计算字节数组、字符串、文件的BASE64编码及解码。明晨网络Mingchennet.com收集整理，其中的InitBase函数用来初始化编码字典，默认使用标准字典，如果自行指定，可以实现一定程度上的加密及解密。
 

  1. '========================================  
  2.    '模块名称：Base64  
  3.    '模块说明：本模块用来实现Base64字符串、二进制数据的编码解码  
  4.    '最后更新： 明晨网络 www.MingchenNet.com 2009-05-31 21:57  
  5.    '========================================  
  6. Option Explicit  
  7. Dim Base64Chr         As String 
  8. Dim NullChr As String 
  9. Dim psBase64Chr(0 To 63)    As String 
  10.    
  11. Function InitBase(ByVal Base64Chr As String)  
  12.     '如果没有提供字符串则按照标准编码  
  13.    If Base64Chr = "" Then Base64Chr = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" 
  14.     Dim iPtr    As Integer 
  15.     '初始化 BASE64数组  
  16.    For iPtr = 0 To 63  
  17.         psBase64Chr(iPtr) = Mid$(Base64Chr, iPtr + 1, 1)  
  18.     Next 
  19.      
  20.     NullChr = Right(Base64Chr, 1)  
  21. End Function 
  22.    
  23. '从一个经过Base64的字符串中解码到源字符串  
  24. Function DecodeBase64String(str2Decode As String) As String 
  25.     DecodeBase64String = StrConv(DecodeBase64Byte(str2Decode), vbUnicode)  
  26. End Function 
  27.    
  28. '从一个经过Base64的字符串中解码到源字节数组  
  29. Function DecodeBase64Byte(str2Decode As String) As Byte()  
  30.      
  31.     Dim lPtr            As Long 
  32.     Dim iValue          As Integer 
  33.     Dim iLen            As Integer 
  34.     Dim iCtr            As Integer 
  35.     Dim Bits(1 To 4)    As Byte 
  36.     Dim strDecode       As String 
  37.     Dim Str             As String 
  38.     Dim Output()        As Byte 
  39.      
  40.     Dim iIndex          As Long 
  41.      
  42.     Dim lFrom As Long 
  43.     Dim lTo As Long 
  44.      
  45.     '//除去回车  
  46.    Str = Replace(str2Decode, vbCrLf, "")  
  47.      
  48.     '//每4个字符一组（4个字符表示3个字）  
  49.    For lPtr = 1 To Len(Str) Step 4  
  50.         iLen = 4  
  51.         For iCtr = 0 To 3  
  52.             '//查找字符在BASE64字符串中的位置  
  53.            iValue = InStr(1, Base64Chr, Mid$(Str, lPtr + iCtr, 1), vbBinaryCompare)  
  54.             Select Case iValue  'A~Za~z0~9+/  
  55.            Case 1 To 64:  
  56.                 Bits(iCtr + 1) = iValue - 1  
  57.             Case 65         '=  
  58.                iLen = iCtr  
  59.                 Exit For 
  60.                 '//没有发现  
  61.            Case 0: Exit Function 
  62.             End Select 
  63.         Next 
  64.          
  65.         '//转换4个6比特数成为3个8比特数  
  66.        Bits(1) = Bits(1) * &H4 + (Bits(2) And &H30)  &H10  
  67.         Bits(2) = (Bits(2) And &HF) * &H10 + (Bits(3) And &H3C)  &H4  
  68.         Bits(3) = (Bits(3) And &H3) * &H40 + Bits(4)  
  69.          
  70.         '//计算数组的起始位置  
  71.        lFrom = lTo  
  72.         lTo = lTo + (iLen - 1) - 1  
  73.          
  74.         '//重新定义输出数组  
  75.        ReDim Preserve Output(0 To lTo)  
  76.          
  77.         For iIndex = lFrom To lTo  
  78.             Output(iIndex) = Bits(iIndex - lFrom + 1)  
  79.         Next 
  80.          
  81.         lTo = lTo + 1  
  82.          
  83.     Next 
  84.     DecodeBase64Byte = Output  
  85. End Function 
  86.    
  87. '将一个字节数组进行Base64编码，并返回字符串  
  88. Function EncodeBase64Byte(sValue() As Byte) As String 
  89.     Dim lCtr                As Long 
  90.     Dim lPtr                As Long 
  91.     Dim lLen                As Long 
  92.     Dim sEncoded            As String 
  93.     Dim Bits8(1 To 3)       As Byte 
  94.     Dim Bits6(1 To 4)       As Byte 
  95.     Dim i As Integer 
  96.     For lCtr = 1 To UBound(sValue) + 1 Step 3  
  97.         For i = 1 To 3  
  98.             If lCtr + i - 2 <= UBound(sValue) Then 
  99.                 Bits8(i) = sValue(lCtr + i - 2)  
  100.                 lLen = 3  
  101.             Else 
  102.                 Bits8(i) = 0  
  103.                 lLen = lLen - 1  
  104.             End If 
  105.         Next 
  106.          
  107.         '//转换字符串为数组，然后转换为4个6位(0-63)  
  108.        Bits6(1) = (Bits8(1) And &HFC)  4  
  109.         Bits6(2) = (Bits8(1) And &H3) * &H10 + (Bits8(2) And &HF0)  &H10  
  110.         Bits6(3) = (Bits8(2) And &HF) * 4 + (Bits8(3) And &HC0)  &H40  
  111.         Bits6(4) = Bits8(3) And &H3F  
  112.          
  113.         '//添加4个新字符  
  114.        For lPtr = 1 To lLen + 1  
  115.             sEncoded = sEncoded & psBase64Chr(Bits6(lPtr))  
  116.         Next 
  117.     Next 
  118.      
  119.     '//不足4位，以=填充  
  120.    Select Case lLen + 1  
  121.     Case 2: sEncoded = sEncoded & NullChr & NullChr  
  122.     Case 3: sEncoded = sEncoded & NullChr  
  123.     Case 4:  
  124.     End Select 
  125.      
  126.     EncodeBase64Byte = sEncoded  
  127. End Function 
  128.    
  129.    
  130. '对字符串进行Base64编码并返回字符串  
  131. Function EncodeBase64String(str2Encode As String) As String 
  132.     Dim sValue()            As Byte 
  133.     sValue = StrConv(str2Encode, vbFromUnicode)  
  134.     EncodeBase64String = EncodeBase64Byte(sValue)  
  135. End Function 
  136.    
  137. '对文件进行Base64编码并返回编码后的Base64字符串  
  138. Function EncodFileToBase64String(strFileSource As String)  
  139.     Dim lpdata() As Byte, i As Long, n As Long 
  140.     i = FreeFile  
  141.     Open strFileSource For Binary Access Read Lock Write As i  
  142.     n = LOF(i) - 1  
  143.     ReDim lpdata(0 To n)  
  144.     Get i, , lpdata  
  145.     Close i  
  146.     EncodFileToBase64String = EncodeBase64Byte(lpdata)  
  147. End Function 
  148.    
  149.    
  150. '将一个Base64字符串解码，并写入二进制文件  
  151. Function DecodeBase64StringToFile(strBase64 As String, strFilePath As String)  
  152.     Dim i As Integer 
  153.     i = FreeFile  
  154.     Open strFilePath For Binary Access Write As i  
  155.     Put i, , DecodeBase64Byte(strBase64)  
  156.     Close i  
  157. End Function 
  158.    
  159.    
  160.    
  161.    
  162. Private Sub Class_initialize()  
  163.     InitBase "" 
  164. End Sub 

文章源自:明晨网络，admin，《VB下的BASE64编码类模块》，http://www.mingchennet.com/tec/code/vb/24.htm