www.pudn.com > isodecod.zip > ISODecod.bas
Attribute VB_Name = "modISODecodingFunctions"
Option Explicit
'--------------------------------------------------------------------------
'
' Author: Ramon Bosch Smit
' 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) = "¡" ' inverted exclamation
p_astrISOTable(162) = "¢" ' cent sign
p_astrISOTable(163) = "£" ' pound sterling
p_astrISOTable(164) = "¤" ' general currency sign
p_astrISOTable(165) = "¥" ' yen sign
p_astrISOTable(166) = "¦" ' broken vertical bar
p_astrISOTable(167) = "§" ' section sign
p_astrISOTable(168) = "¨" ' umlaut (dieresis)
p_astrISOTable(169) = "©" ' copyright
p_astrISOTable(170) = "ª" ' feminine ordinal
p_astrISOTable(171) = "«" ' left angle quote, guillemotleft
p_astrISOTable(172) = "¬" ' not sign
p_astrISOTable(173) = "" ' soft hyphen
p_astrISOTable(174) = "®" ' registered trademark
p_astrISOTable(175) = "¯" ' macron accent
p_astrISOTable(176) = "°" ' degree sign
p_astrISOTable(177) = "±" ' plus or minus
p_astrISOTable(178) = "²" ' superscript two
p_astrISOTable(179) = "³" ' superscript three
p_astrISOTable(180) = "´" ' acute accent
p_astrISOTable(181) = "µ" ' micro sign
p_astrISOTable(182) = "¶" ' paragraph sign
p_astrISOTable(183) = "·" ' middle dot
p_astrISOTable(184) = "¸" ' cedilla
p_astrISOTable(185) = "¹" ' superscript one
p_astrISOTable(186) = "º" ' masculine ordinal
p_astrISOTable(187) = "»" ' right angle quote, guillemotright
p_astrISOTable(188) = "¼" ' fraction one-fourth
p_astrISOTable(189) = "½" ' fraction one-half
p_astrISOTable(190) = "¾" ' fraction three-fourths
p_astrISOTable(191) = "¿" ' inverted question mark
p_astrISOTable(192) = "À" ' capital A, grave accent
p_astrISOTable(193) = "Á" ' capital A, acute accent
p_astrISOTable(194) = "Â" ' capital A, circumflex accent
p_astrISOTable(195) = "Ã" ' capital A, tilde
p_astrISOTable(196) = "Ä" ' capital A, dieresis or umlaut mark
p_astrISOTable(197) = "Å" ' capital A, ring
p_astrISOTable(198) = "Æ" ' capital AE diphthong (ligature)
p_astrISOTable(199) = "Ç" ' capital C, cedilla
p_astrISOTable(200) = "È" ' capital E, grave accent
p_astrISOTable(201) = "É" ' capital E, acute accent
p_astrISOTable(202) = "Ê" ' capital E, circumflex accent
p_astrISOTable(203) = "Ë" ' capital E, dieresis or umlaut mark
p_astrISOTable(204) = "Ì" ' capital I, grave accent
p_astrISOTable(205) = "Í" ' capital I, acute accent
p_astrISOTable(206) = "Î" ' capital I, circumflex accent
p_astrISOTable(207) = "Ï" ' capital I, dieresis or umlaut mark
p_astrISOTable(208) = "Ð" ' capital Eth, Icelandic
p_astrISOTable(209) = "Ñ" ' capital N, tilde
p_astrISOTable(210) = "Ò" ' capital O, grave accent
p_astrISOTable(211) = "Ó" ' capital O, acute accent
p_astrISOTable(212) = "Ô" ' capital O, circumflex accent
p_astrISOTable(213) = "Õ" ' capital O, tilde
p_astrISOTable(214) = "Ö" ' capital O, dieresis or umlaut mark
p_astrISOTable(215) = "×" ' multiply sign
p_astrISOTable(216) = "Ø" ' capital O, slash
p_astrISOTable(217) = "Ù" ' capital U, grave accent
p_astrISOTable(218) = "Ú" ' capital U, acute accent
p_astrISOTable(219) = "Û" ' capital U, circumflex accent
p_astrISOTable(220) = "Ü" ' capital U, dieresis or umlaut mark
p_astrISOTable(221) = "Ý" ' capital Y, acute accent
p_astrISOTable(222) = "Þ" ' capital THORN, Icelandic
p_astrISOTable(223) = "ß" ' small sharp s, German (sz ligature)
p_astrISOTable(224) = "à" ' small a, grave accent
p_astrISOTable(225) = "á" ' small a, acute accent
p_astrISOTable(226) = "â" ' small a, circumflex accent
p_astrISOTable(227) = "ã" ' small a, tilde
p_astrISOTable(228) = "ä" ' small a, dieresis or umlaut mark
p_astrISOTable(229) = "å" ' small a, ring
p_astrISOTable(230) = "æ" ' small ae diphthong (ligature)
p_astrISOTable(231) = "ç" ' small c, cedilla
p_astrISOTable(232) = "è" ' small e, grave accent
p_astrISOTable(233) = "é" ' small e, acute accent
p_astrISOTable(234) = "ê" ' small e, circumflex accent
p_astrISOTable(235) = "ë" ' small e, dieresis or umlaut mark
p_astrISOTable(236) = "ì" ' small i, grave accent
p_astrISOTable(237) = "í" ' small i, acute accent
p_astrISOTable(238) = "î" ' small i, circumflex accent
p_astrISOTable(239) = "ï" ' small i, dieresis or umlaut mark
p_astrISOTable(240) = "ð" ' small eth, Icelandic
p_astrISOTable(241) = "ñ" ' small n, tilde
p_astrISOTable(242) = "ò" ' small o, grave accent
p_astrISOTable(243) = "ó" ' small o, acute accent
p_astrISOTable(244) = "ô" ' small o, circumflex accent
p_astrISOTable(245) = "õ" ' small o, tilde
p_astrISOTable(246) = "ö" ' small o, dieresis or umlaut mark
p_astrISOTable(247) = "÷" ' division sign
p_astrISOTable(248) = "ø" ' small o, slash
p_astrISOTable(249) = "ù" ' small u, grave accent
p_astrISOTable(250) = "ú" ' small u, acute accent
p_astrISOTable(251) = "û" ' small u, circumflex accent
p_astrISOTable(252) = "ü" ' small u, dieresis or umlaut mark
p_astrISOTable(253) = "ý" ' small y, acute accent
p_astrISOTable(254) = "þ" ' small thorn, Icelandic
p_astrISOTable(255) = "ÿ" ' small y, dieresis or umlaut mark
Case Else
' TODO: Implement support for Charsets other than ISO-8859-1 (Latin)
End Select
ExitHere:
Exit Sub
ErrorHandler:
Debug.Assert 0 ' Soft stop
' TODO: Implement your error hanling/logging here
Resume ExitHere
End Sub