isodecod.bas

Base64的Decode和Encode

Attribute VB_Name = "modISODecodingFunctions"
Option Explicit

'--------------------------------------------------------------------------
'
' Author:       Ramon Bosch Smit <[e-mail]>
' DateCreated:  10/09/1999
' Description:  ISO charset decoder function + support functions
' ModuleType:   BAS
'
'--------------------------------------------------------------------------


' MIME supports techiques to allow the encoding of non-ASCII text
' in various portions of a message header in a manner that is unlikely
' to confuse message-handling software that does not support these
' features.
'
' Certain sequences of ordinary printable ASCII characters (known as
' encoded-words= are reserved for use as encoded data. The syntax of
' encoded-words is such that they are unlikely to accidentally appear
' as normal text in message headers. Furthermore, the characters used
' in encoded-words are restricted to those that do not have special
' meaning in the context in which the encoded word appears.
'
' Generally, an encoded-word is a sequence of printable ASCII characters
' that begin with =?, end with ?=, and have two ?'s in between.  It
' specifies a character set and an encoding method and also includes
' the original text encoded as graphic ASCII characters, according to
' the rules for that encoding method
'
' Syntax:
'
' Encoded-word = "=?" charset "?" encoding "?" encoded-text "?="


Public Function DecodeWord _
                        ( _
                        ByVal p_strEncodedExpression As String, _
                        Optional ByRef p_strCharset As String, _
                        Optional ByRef p_strEncoding As String _
                        ) As String
    ' Description:
    '----------------------------------------------------------------------
    ' Decodes a MIME encoded string (following the RFC 2047 specification)
    
    ' Parameters:
    '----------------------------------------------------------------------
    ' In            p_strEncodedExpression  Encoded string
    ' Out           p_strCharset            Original Charset
    '               p_strEncoding           Encoding method used to
    '                                       encode the original text.
    '                                       Legal values for encoding are:
    '                                       "Q" Quoted Printable
    '                                       "B" Base64 (not supported)
    '                                       ""  Means that p_strEncodedExpression
    '                                       wasn't encoded
    ' Return value:
    '-----------------------------------------------------------------------
    ' Decoded string (the original text in the designated character set)
    
    Dim v_lngLength             As Long
    Dim v_lngIndex              As Long
    
    Dim v_strCurrentChar        As String
    Dim v_strCharset            As String
    Dim v_strEncodedChar        As String
    Dim v_strEncoding           As String
    Dim v_strDecoded            As String
    
    Dim v_blnDecoding           As Boolean
    Dim v_blnDecodingChar       As Boolean
    Dim v_blnFetchingCharset    As Boolean
    Dim v_blnFetchingEncoding   As Boolean
    Dim v_blnFetchingChar       As Boolean
    
    On Error GoTo ErrorHandler
    
    v_lngLength = Len(p_strEncodedExpression)
    
    For v_lngIndex = 1 To v_lngLength
        
        v_strCurrentChar = Mid$(p_strEncodedExpression, v_lngIndex, 1)
        
        Select Case v_strCurrentChar
        
        Case "="
                        
            If UCase$(Mid$(p_strEncodedExpression, v_lngIndex + 1, Len("?ISO"))) = "?ISO" Then
                
                v_blnDecoding = True
                v_blnFetchingCharset = True
                v_blnFetchingEncoding = False
                v_blnDecodingChar = False
                v_blnFetchingChar = False
                v_lngIndex = v_lngIndex + 1
            
            ElseIf v_blnDecodingChar Then
                
                v_blnFetchingChar = True
            
            End If
            
        Case "?"
            
            If v_blnFetchingCharset Then
                
                v_blnFetchingCharset = False
                v_blnFetchingEncoding = True
            
            ElseIf v_blnFetchingEncoding Then
                
                v_blnFetchingEncoding = False
                v_blnDecodingChar = True
            
            ElseIf Mid$(p_strEncodedExpression, v_lngIndex + 1, 1) = "=" Then
                
                v_blnDecoding = False
                v_blnDecodingChar = False
                v_blnFetchingCharset = False
                v_blnFetchingEncoding = False
            
            Else
                
                v_strDecoded = v_strDecoded & v_strCurrentChar
                
            End If
        
        Case "_"
            
            If v_blnDecoding Then
                
                v_strDecoded = v_strDecoded & " "
            
            End If
            
        Case Else
            
            If v_blnFetchingCharset Then
                
                v_strCharset = v_strCharset & v_strCurrentChar
            
            ElseIf v_blnFetchingEncoding Then
                
                v_strEncoding = v_strEncoding & v_strCurrentChar
            
            ElseIf v_blnFetchingChar Then
                
                v_strEncodedChar = v_strEncodedChar & v_strCurrentChar
                
                If Len(v_strEncodedChar) = 2 Then
                    
                    v_blnFetchingChar = False
                    v_strDecoded = v_strDecoded & DecodeChar(v_strEncodedChar, v_strCharset)
                    v_strEncodedChar = vbNullString
                
                End If
             
            Else
                
                v_strDecoded = v_strDecoded & v_strCurrentChar
            
            End If
                    
        End Select
    
    Next v_lngIndex
    
    DecodeWord = v_strDecoded
    p_strCharset = v_strCharset
    p_strEncoding = v_strEncoding
    
ExitHere:
    Exit Function
ErrorHandler:
    Debug.Assert 0  ' Soft stop
    ' TODO: Implement your error hanling/logging here
    Resume ExitHere
End Function

Private Function DecodeChar _
                        ( _
                        ByVal p_strEncodedChar As String, _
                        ByVal p_strCharset As String _
                        ) As String

    ' Description:
    '----------------------------------------------------------------------
    ' Decodes an expression that represents an encoded character to it's
    ' original charset (p_strCharset). In order to do so, p_strEncodedChar,
    ' which is an Hexadecimal number expression,  must be converted to it's decimal
    ' value and then converted to a character through a conversion table
    '
    ' Parameters:
    '----------------------------------------------------------------------
    ' In            p_strEncodedChar        Hexadecimal expression
    '               p_strCharset            Original Charset
    '
    ' Out           None
    '
    ' Return value:
    '-----------------------------------------------------------------------
    ' Decoded character
    
    Dim v_astrISOTable() As String
    Dim v_lngISOCode As Long

    On Error GoTo ErrorHandler
    
    ' Convert the encoded Character (2 digit Hexadecimal number) to
    ' it's decimal value
    v_lngISOCode = HexToDec(p_strEncodedChar)
    ' Load the corresponding ISO Conversion table for
    ' the specified Charset
    LoadISOTable p_strCharset, v_astrISOTable
    ' Lookup the corresponding character in the conversion table
    DecodeChar = v_astrISOTable(v_lngISOCode)

ExitHere:
    Exit Function
ErrorHandler:
    Debug.Assert 0  ' Soft stop
    ' TODO: Implement your error hanling/logging here
    Resume ExitHere
End Function

Private Function HexToDec _
                        ( _
                        ByVal p_strHexNumber As String _
                        ) As Double
    
    
    ' Description:
    '----------------------------------------------------------------------
    ' Converts an Hexadecimal number (expression) to it's decimal value
    '
    ' Parameters:
    '----------------------------------------------------------------------
    ' In            p_strHexNumber          Hexadecimal number
    '
    ' Out           None
    '
    ' Return value:
    '-----------------------------------------------------------------------
    ' Decimal number resulting from the conversion of p_strHexNumber
    
    Dim v_lngNumberLength As Long
    Dim v_lngIndex As Long
    Dim v_dblDecimalNumber As Double
    Dim v_strHexadecimalDigit As String
    Dim v_lngDecimalDigit As Long
    
    On Error GoTo ErrorHandler
    
    v_lngNumberLength = Len(p_strHexNumber)
    
    ' If the length of p_strHexNumber is = 0 then the
    ' function shall return 0 (Decimal)
    
    If v_lngNumberLength > 0 Then
    
        For v_lngIndex = 1 To v_lngNumberLength
                    
            v_strHexadecimalDigit = Mid$(p_strHexNumber, v_lngIndex, 1)
            
            If IsNumeric(v_strHexadecimalDigit) Then
                
                v_lngDecimalDigit = CLng(v_strHexadecimalDigit)
            
            Else
                
                If InStr(1, "ABCDEF", v_strHexadecimalDigit, vbTextCompare) > 0 Then
                
                    v_lngDecimalDigit = Asc(UCase$(v_strHexadecimalDigit)) - 55
            
                Else
                        
                    ' If p_strHexNumber is an invalid Hexadecimal number then we'll
                    ' raise an exception
                    
                    VBA.Err.Raise 5 ' Invalid procedure call
                        
                End If
            
            End If
            
            v_dblDecimalNumber = v_dblDecimalNumber + (v_lngDecimalDigit * (16 ^ (v_lngNumberLength - v_lngIndex)))
        
        Next v_lngIndex
    
    End If

    HexToDec = v_dblDecimalNumber

ExitHere:
    Exit Function
ErrorHandler:
    Debug.Assert 0  ' Soft here
    HexToDec = 0
    ' TODO: Implement your error hanling/logging here
    Resume ExitHere
End Function

Private Sub LoadISOTable _
                        ( _
                        ByVal p_strCharset As String, _
                        ByRef p_astrISOTable() As String _
                        )
    
    ' Description:
    '----------------------------------------------------------------------
    ' Loads a Conversion Table into the p_astrISOTable array.
    ' Each index of the array corresponds to the decimal value of an encoded
    ' Character. e.g: Hexadecimal "3D" = Decimal 61. Index 61 of the array
    ' will contain the decoded value of "3D". If "3D" was encoded using
    ' the ISO-8859-1 charset, then we shall load the ISO-8859-1 conversion table
    ' into the array, which'll give us "=" as the decoded value of "3D"
    '
    ' Parameters:
    '----------------------------------------------------------------------
    ' In            p_strCharset            Charset for which the convesrsion
    '                                       table must be loaded
    '               p_astrISOTable          Empty Array
    ' Out           p_astrISOTable          Loaded Array (contains the conversion
    '                                       table for p_strCharset)
    '
    ' Return value:
    '-----------------------------------------------------------------------
    ' None

    On Error GoTo ErrorHandler
    
    ReDim p_astrISOTable(0 To 255)
    
    Select Case UCase$(p_strCharset)
    
    Case "ISO-8859-1"
        
        ' Load the ISO-8859-1 Conversion table
        
        p_astrISOTable(32) = " "    ' white space
        p_astrISOTable(34) = """"   ' quotation mark
        p_astrISOTable(38) = "&"    ' ampersand
        p_astrISOTable(60) = "<"    ' less-than sign
        p_astrISOTable(61) = "="    ' equal sign
        p_astrISOTable(62) = ">"    ' greater-than sign
        p_astrISOTable(63) = "?"    ' question mark
        p_astrISOTable(160) = " "   ' non-breaking space
        p_astrISOTable(161) = "