怎样采用Base64_Encode编码形式？

怎样采用Base64_Encode编码形式？

解决方案 »

  1.   

    Public Function Base64Encode(strOriginal As String)
        Dim intCount As Integer
        Dim strBinary As String
        Dim intDecimal As Integer
        Dim strTemp As String    intDecimal = Asc(Left$(strOriginal, 1))
        
        For intCount = 7 To 0 Step -1
            If (2 ^ intCount) <= intDecimal Then
                strBinary = strBinary & "1"
                intDecimal = intDecimal - (2 ^ intCount)
            Else
                strBinary = strBinary & "0"
            End If
        Next
        
        If Len(strOriginal) < 3 Then GoTo unfpassone
        
        intDecimal = Asc(Mid$(strOriginal, 2, 1))
        
        For intCount = 7 To 0 Step -1
            If (2 ^ intCount) <= intDecimal Then
                strBinary = strBinary & "1"
                intDecimal = intDecimal - (2 ^ intCount)
            Else
                strBinary = strBinary & "0"
            End If
        Next
        
        If Len(strOriginal) < 3 Then GoTo unfpassone
        
        intDecimal = Asc(Right$(strOriginal, 1))
        
        For intCount = 7 To 0 Step -1
            If (2 ^ intCount) <= intDecimal Then
                strBinary = strBinary & "1"
                intDecimal = intDecimal - (2 ^ intCount)
            Else
                strBinary = strBinary & "0"
            End If
        Next
        
    unfpassone:
        For intCount = 1 To 19 Step 6
            Select Case Val(Mid$(strBinary, intCount, 6))
                Case 0
                    strTemp = strTemp & "A"
                Case 1
                    strTemp = strTemp & "B"
                Case 10
                    strTemp = strTemp & "C"
                Case 11
                    strTemp = strTemp & "D"
                Case 100
                    strTemp = strTemp & "E"
                Case 101
                    strTemp = strTemp & "F"
                Case 110
                    strTemp = strTemp & "G"
                Case 111
                    strTemp = strTemp & "H"
                Case 1000
                    strTemp = strTemp & "I"
                Case 1001
                    strTemp = strTemp & "J"
                Case 1010
                    strTemp = strTemp & "K"
                Case 1011
                    strTemp = strTemp & "L"
                Case 1100
                    strTemp = strTemp & "M"
                Case 1101
                    strTemp = strTemp & "N"
                Case 1110
                    strTemp = strTemp & "O"
                Case 1111
                    strTemp = strTemp & "P"
                Case 10000
                    strTemp = strTemp & "Q"
                Case 10001
                    strTemp = strTemp & "R"
                Case 10010
                    strTemp = strTemp & "S"
                Case 10011
                    strTemp = strTemp & "T"
                Case 10100
                    strTemp = strTemp & "U"
                Case 10101
                    strTemp = strTemp & "V"
                Case 10110
                    strTemp = strTemp & "W"
                Case 10111
                    strTemp = strTemp & "X"
                Case 11000
                    strTemp = strTemp & "Y"
                Case 11001
                    strTemp = strTemp & "Z"
                Case 11010
                    strTemp = strTemp & "a"
                Case 11011
                    strTemp = strTemp & "b"
                Case 11100
                    strTemp = strTemp & "c"
                Case 11101
                    strTemp = strTemp & "d"
                Case 11110
                    strTemp = strTemp & "e"
                Case 11111
                    strTemp = strTemp & "f"
                Case 100000
                    strTemp = strTemp & "g"
                Case 100001
                    strTemp = strTemp & "h"
                Case 100010
                    strTemp = strTemp & "i"
                Case 100011
                    strTemp = strTemp & "j"
                Case 100100
                    strTemp = strTemp & "k"
                Case 100101
                    strTemp = strTemp & "l"
                Case 100110
                    strTemp = strTemp & "m"
                Case 100111
                    strTemp = strTemp & "n"
                Case 101000
                    strTemp = strTemp & "o"
                Case 101001
                    strTemp = strTemp & "p"
                Case 101010
                    strTemp = strTemp & "q"
                Case 101011
                    strTemp = strTemp & "r"
                Case 101100
                    strTemp = strTemp & "s"
                Case 101101
                    strTemp = strTemp & "t"
                Case 101110
                    strTemp = strTemp & "u"
                Case 101111
                    strTemp = strTemp & "v"
                Case 110000
                    strTemp = strTemp & "w"
                Case 110001
                    strTemp = strTemp & "x"
                Case 110010
                    strTemp = strTemp & "y"
                Case 110011
                    strTemp = strTemp & "z"
                Case 110100
                    strTemp = strTemp & "0"
                Case 110101
                    strTemp = strTemp & "1"
                Case 110110
                    strTemp = strTemp & "2"
                Case 110111
                    strTemp = strTemp & "3"
                Case 111000
                    strTemp = strTemp & "4"
                Case 111001
                    strTemp = strTemp & "5"
                Case 111010
                    strTemp = strTemp & "6"
                Case 111011
                    strTemp = strTemp & "7"
                Case 111100
                    strTemp = strTemp & "8"
                Case 111101
                    strTemp = strTemp & "9"
                Case 111110
                    strTemp = strTemp & "+"
                Case 111111
                    strTemp = strTemp & "/"
            End Select
        Next
        
        Base64Encode = strTemp
        
    End Function
      

  2.   

    Function EnCode(StrSource As String) As String
        Dim StrOutput1 As String, StrOutput2 As String, StrOutput3 As String
        Do While HaveBase64(StrSource, StrOutput1, StrOutput2, StrOutput3) = 1
        StrSource = StrOutput1 & Base64decode(StrOutput2) & StrOutput3
        Loop
        Do While HaveQuoted(StrSource, StrOutput1, StrOutput2, StrOutput3) = 1
        StrSource = StrOutput1 & QuotedDecode(StrOutput2) & StrOutput3
        Loop
        EnCode = StrSource
    End FunctionFunction HaveBase64(ByVal StrInput, StrOutput1, StrOutput2, StrOutput3) As Integer
        tempa = InStr(1, StrInput, "=?")
        If tempa <> 0 Then
            tempb = InStr(2 + tempa, StrInput, "?B?")
            If tempb > tempa Then
                tempc = InStr(3 + tempb, StrInput, "?=")
                If tempc > tempb Then
                    StrOutput1 = Mid(StrInput, 1, tempa - 1)
                    StrOutput2 = Mid(StrInput, tempb + 3, tempc - tempb - 3)
                    StrOutput3 = Mid(StrInput, tempc + 2, Len(StrInput) - tempc - 1)
                    HaveBase64 = 1
                Exit Function
                End If
            End If
        End If
        HaveBase64 = 0
    End FunctionFunction HaveQuoted(ByVal StrInput, StrOutput1, StrOutput2, StrOutput3) As Integer
        tempa = InStr(1, StrInput, "=?")
        If tempa <> 0 Then
            tempb = InStr(2 + tempa, StrInput, "?Q?")
            If tempb > tempa Then
                tempc = InStr(3 + tempb, StrInput, "?=")
                If tempc > tempb Then
                StrOutput1 = Mid(StrInput, 1, tempa - 1)
                StrOutput2 = Mid(StrInput, tempb + 3, tempc - tempb - 3)
                StrOutput3 = Mid(StrInput, tempc + 2, Len(StrInput) - tempc - 1)
                HaveQuoted = 1
                Exit Function
                End If
            End If
        End If
        HaveQuoted = 0
    End Function
    Function Base64decode(ByVal AsContents As String) As String
      Dim IsResult As String
      Dim inposition As Integer
      Dim IsGroup64 As String, IsGroupBinary As String
      Dim BytSource(3) As Byte
      Dim StrOut(3) As Byte
      'If Len(AsContents) Mod 4 > 0 Then AsContents = AsContents & String(4 - (Len(AsContents) Mod 4), " ")
       
      StrOut(3) = 0
      IsResult = ""
      
      Do While Len(AsContents) > 0
        If Len(AsContents) >= 4 Then
            IsGroup64 = Left(AsContents, 4) '取前四个字符
            AsContents = Right(AsContents, Len(AsContents) - 4) '将取走的前四个字符去掉
        Else
            IsGroup64 = AsContents
            AsContents = ""
        End If
        
        For inposition = 0 To Len(IsGroup64) - 1
            BytSource(inposition) = table(Mid(IsGroup64, inposition + 1, 1))
        Next inposition
        
        
        StrOut(0) = (BytSource(0) Mod 64) * 4 + Int(BytSource(1) / 16)
        StrOut(1) = (BytSource(1) Mod 16) * 16 + Int(BytSource(2) / 4)
        StrOut(2) = (BytSource(2) Mod 4) * 64 + BytSource(3)
        
        If StrOut(3) <> 0 Then  '前一段残留下来的半个汉字
            IsResult = IsResult & Chr(StrOut(3) * 2 ^ 8 + StrOut(0))
            If StrOut(1) > &H80 Then
                '第二个字节和第三个字节组成汉字
                IsResult = IsResult & Chr(StrOut(1) * 2 ^ 8 + StrOut(2))
                StrOut(3) = 0
            Else
                IsResult = IsResult & Chr(StrOut(1)) '第二个字节是英文
                If StrOut(2) > &H80 Then
                   '第三个字节半个汉字，留给下一次处理
                   StrOut(3) = StrOut(2)
                Else
                    IsResult = IsResult & Chr(StrOut(2))
                    StrOut(3) = 0
                End If
            End If
        Else            '上一段全部转换完成
            If StrOut(0) < &H80 Then
                '第一位是英文
                IsResult = IsResult & Chr(StrOut(0))
                If StrOut(1) < &H80 Then
                    IsResult = IsResult & Chr(StrOut(1))    '第二位也是英文
                    If StrOut(2) < &H80 Then
                        IsResult = IsResult & Chr(StrOut(2))
                        StrOut(3) = 0
                    Else
                        StrOut(3) = StrOut(2)
                    End If
                Else
                    '第二位是汉字
                    IsResult = IsResult & Chr(StrOut(1) * 2 ^ 8 + StrOut(2))
                    StrOut(3) = 0
                End If
            Else
                '第一个字节和第二个字节表示一个汉字
                IsResult = IsResult & Chr(StrOut(0) * 2 ^ 8 + StrOut(1))
                If StrOut(2) < &H80 Then
                    IsResult = IsResult & Chr(StrOut(2))
                    StrOut(3) = 0
                Else
                    StrOut(3) = StrOut(2)
                End If
            End If
        End If
      Loop
      
      Base64decode = StrDelNul(IsResult)
      Debug.Print Base64decode
    End FunctionFunction table(ByVal decode As String)
      If "A" <= decode And decode <= "Z" Then
        table = Asc(decode) - 65
        Exit Function
      End If
      If "a" <= decode And decode <= "z" Then
        table = Asc(decode) - 71
        Exit Function
      End If
      If "0" <= decode And decode <= "9" Then
        table = Asc(decode) + 4
        Exit Function
      End If
      If decode = "+" Or decode = "/" Then
        table = Asc(decode) + 19
        Exit Function
      End If
    End FunctionFunction StrDelNul(ByVal StrIn As String) As String
    i = Len(StrIn)
    Do While Asc(Mid(StrIn, i, 1)) = 0
        i = i - 1
    Loop
    StrDelNul = Mid(StrIn, 1, i)
    End FunctionFunction QuotedDecode(ByVal AsContents As String) As String
    Dim AsContents_Length As Integer
    Dim IsResult As String, IsGroupBinary As String
    Dim i As Integer, chr_ As String, char1 As String, char2 As String
    Dim byt As Integer, byte1 As Integer, byte2 As IntegerAsContents_Length = Len(AsContents)
    IsResult = ""
    i = 1
    Do While i <= AsContents_Length
        IsGroupBinary = ""
        chr_ = Mid(AsContents, i, 1)
        i = i + 1
        If chr_ = "=" Then
        '==============中文处理=============='
            '前2个字符--转换成asc码 并存入byt
            char1 = Mid(AsContents, i, 1)
            i = i + 1
            char2 = Mid(AsContents, i, 1)
            i = i + 1
            If char1 > "9" Then
                byte1 = Asc(char1) - 65 + 10
            Else
                byte1 = Asc(char1) - 48
            End If
            If char2 > "9" Then
                byte2 = Asc(char2) - 65 + 10
            Else
                byte2 = Asc(char2) - 48
            End If
            byt = byte1 * 16 + byte2
            If byt = &H3D Then
            '==========="="的编码---是特殊e文======'
                IsGroupBinary = "="
                GoTo A_CHAR_OVER
            End If
            '后两个字符-转换成asc码 and 忽略"="
            i = i + 1
            char1 = Mid(AsContents, i, 1)
            i = i + 1
            char2 = Mid(AsContents, i, 1)
            i = i + 1
            If char1 > "9" Then
                byte1 = Asc(char1) - 65 + 10
            Else
                byte1 = Asc(char1) - 48
            End If
            If char2 > "9" Then
                byte2 = Asc(char2) - 65 + 10
            Else
                byte2 = Asc(char2) - 48
            End If
            '组合成汉字
            IsGroupBinary = Chr(byt * 2 ^ 8 + byte1 * 16 + byte2)
        Else
        '================e文处理=============='
            IsGroupBinary = chr_
        End If
    A_CHAR_OVER:
        IsResult = IsResult + IsGroupBinary
    Loop
    QuotedDecode = IsResult
    End Function
      

  3.   

    我试了一下，不行，能不能来个简单点的，例如：Public Function Base64Encode(strOriginal As String)但能够支持汉字和所有二进制文件