给贝贝的，Base64编码（带有Q和B编码）—

给贝贝的，Base64编码（带有Q和B编码）——VB.NET

- 中国WEB开发者网络 (http://www.webasp.net)
-- 技术教程 (http://www.webasp.net/article/)
--- 给贝贝的，Base64编码（带有Q和B编码）——VB.NET (http://www.webasp.net/article/5/4181.htm)

-- 作者：未知
-- 发布日期： 2003-07-12

Option Strict Off
Option Explicit On
Option Compare Text
Imports Microsoft.VisualBasic.Compatibility
Namespace Blood.Com.ClassLib
    Public Class Security

        Private pbBase64Byt(63) As Byte

        Private Const BASE64CHR As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="

        Private Const Q_CODE_HDR As String = "=?ISO-8859-1?Q?"
        Private Const B_CODE_HDR As String = "=?ISO-8859-1?B?"
        Private Const CODE_END As String = "?="

        Public Sub New()
            MyBase.New()
            Dim intPtr As Integer
            For intPtr = 0 To 63
                pbBase64Byt(intPtr) = Asc(Mid(BASE64CHR, intPtr + 1, 1))
            Next
        End Sub

        Protected Overrides Sub Finalize()
            MyBase.Finalize()
        End Sub

        '对字符串进行B或Q编码
        Public Function EnText(ByRef sIn As String) As String
            Dim iPtr As Short
            Dim bNeedsEncoding As Boolean
            Dim iMax As Short
            Dim sChr As String
            Dim sLine As String
            Dim sQCode As String
            Dim sBCode As String
            Dim bytTmp() As Byte
            bytTmp = System.Text.UnicodeEncoding.Default.GetBytes(sIn)
            For iPtr = 0 To UBound(bytTmp)
                If bytTmp(iPtr) > 126 Then
                    bNeedsEncoding = True
                    Exit For
                End If
            Next
            EnText = sIn

            'Q 编码
            iMax = 54
            For iPtr = 1 To Len(sIn)
                sChr = Mid(sIn, iPtr, 1)
                Select Case Asc(sChr)
                    Case 33 To 60, 62, 64 To 94, 96 To 126
                        sLine = sLine & sChr
                    Case 32
                        sLine = sLine & "_"
                    Case Else
                        sLine = sLine & "=" & Right("00" & Hex(Asc(sChr)), 2)
                End Select
                If Len(sLine) >= iMax Then
                    sQCode = sQCode & Q_CODE_HDR & sLine & CODE_END
                    If iPtr < Len(sIn) Then sQCode = sQCode & vbCrLf & vbTab
                    sLine = ""
                End If
            Next
            sQCode = sQCode & Q_CODE_HDR & sLine & CODE_END

            'B 编码
            iMax = 42
            sLine = sIn
            Do While Len(sLine)
                sBCode = sBCode & B_CODE_HDR & Encode(Mid(sLine, 1, iMax))
                sBCode = Mid(sBCode, 1, Len(sBCode) - 2) & CODE_END
                sLine = Mid(sLine, iMax + 1)
                If Len(sLine) Then sBCode = sBCode & vbCrLf & vbTab
            Loop

            If Len(sQCode) < Len(sBCode) Then
                EnText = sQCode
            Else
                EnText = sBCode
            End If

        End Function

        '解码字符串
        Public Function Decode(ByVal str2Decode As String) As String

            Dim lPtr As Integer
            Dim iValue As Short
            Dim iLen As Short
            Dim iCtr As Short
            Dim Bits(4) As Byte
            Dim strDecode As String

            For lPtr = 1 To Len(str2Decode) Step 4
                iLen = 4
                For iCtr = 0 To 3
                    iValue = InStr(1, BASE64CHR, Mid(str2Decode, lPtr + iCtr, 1), CompareMethod.Binary)
                    Select Case iValue
                        Case 1 To 64 : Bits(iCtr + 1) = iValue - 1
                        Case 65
                            iLen = iCtr
                            Exit For
                        Case 0
                            Exit Function
                    End Select
                Next

                Bits(1) = Bits(1) * &H4S + (Bits(2) And &H30S) \ &H10S
                Bits(2) = CShort(Bits(2) And &HFS) * &H10S + (Bits(3) And &H3CS) \ &H4S
                Bits(3) = CShort(Bits(3) And &H3S) * &H40S + Bits(4)

                For iCtr = 1 To iLen - 1
                    strDecode = strDecode & Chr(Bits(iCtr))
                Next

            Next

            Decode = strDecode

        End Function

        '对字节进行编码（可以直接进行文件的编码）
        Public Function EncodeByte(ByRef InArray() As Byte) As Byte()
            Dim lInPtr As Integer
            Dim lOutPtr As Integer
            Dim OutArray() As Byte
            Dim lLen As Integer
            Dim iNewLine As Integer
            lLen = (UBound(InArray) - LBound(InArray) + 1) Mod 3
            If lLen Then
                lLen = 3 - lLen
                ReDim Preserve InArray(UBound(InArray) + lLen)
            End If
            ReDim OutArray(UBound(InArray) * 2 + 100)
            For lInPtr = 0 To UBound(InArray) Step 3
                If iNewLine = 19 Then
                    OutArray(lOutPtr) = 13
                    OutArray(lOutPtr + 1) = 10
                    lOutPtr = lOutPtr + 2
                    iNewLine = 0
                End If
                OutArray(lOutPtr) = pbBase64Byt((InArray(lInPtr) And &HFCS) \ 4)
                OutArray(lOutPtr + 1) = pbBase64Byt(CShort(InArray(lInPtr) And &H3S) * &H10S + (InArray(lInPtr + 1) And &HF0S) \ &H10S)
                OutArray(lOutPtr + 2) = pbBase64Byt(CShort(InArray(lInPtr + 1) And &HFS) * 4 + (InArray(lInPtr + 2) And &HC0S) \ &H40S)
                OutArray(lOutPtr + 3) = pbBase64Byt(InArray(lInPtr + 2) And &H3FS)
                lOutPtr = lOutPtr + 4
                iNewLine = iNewLine + 1
            Next
            Select Case lLen
                Case 1
                    OutArray(lOutPtr - 1) = 61
                Case 2
                    OutArray(lOutPtr - 1) = 61
                    OutArray(lOutPtr - 2) = 61
            End Select
            If OutArray(lOutPtr - 2) <> 13 Then
                OutArray(lOutPtr) = 13
                OutArray(lOutPtr + 1) = 10
                lOutPtr = lOutPtr + 2
            End If
            ReDim Preserve OutArray(lOutPtr - 1)
            EncodeByte = VB6.CopyArray(OutArray)
        End Function

        '对字符串进行编码
        Public Function Encode(ByRef str2Encode As String) As String
            Dim tmpByte() As Byte
            If Len(str2Encode) Then
                tmpByte = System.Text.UnicodeEncoding.Default.GetBytes(str2Encode)
                tmpByte = EncodeByte(tmpByte)
                Encode = System.Text.UnicodeEncoding.Unicode.GetString(tmpByte)
            End If
        End Function
    End Class
End Namespace

webasp.net