644 lines
45 KiB
VB.net
644 lines
45 KiB
VB.net
Option Strict On
|
||
Option Explicit On
|
||
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
' Utilities - Copyright 2011 © by David Ross Goben.
|
||
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||
Imports System.Text, VB = Microsoft.VisualBasic
|
||
|
||
Public Class Utilities
|
||
|
||
'*******************************************************************************
|
||
' Function Name : DecodeBase64ToStr
|
||
' Purpose : Decode a provided raw email message string that is encoded to Base64.
|
||
' :
|
||
' Returns : Decoded String
|
||
' :
|
||
' NOTES : note that the lone vbCrLf at the end of lines is filtered out.
|
||
'*******************************************************************************
|
||
Public Shared Function DecodeBase64ToStr(ByVal strData As String) As String
|
||
Return Encoding.UTF8.GetChars(DecodeBase64ToBytes(strData))
|
||
End Function
|
||
|
||
'*******************************************************************************
|
||
' Function Name : DecodeBase64ToBytes
|
||
' Purpose : Decode a provided raw email message string that is encoded to Base64.
|
||
' :
|
||
' Returns : Decoded binary Byte Array
|
||
' :
|
||
' NOTES : note that the lone vbCrLf at the end of lines is filtered out.
|
||
'*******************************************************************************
|
||
'this modification returns a Byte Array of the Base64 encoded source data
|
||
Public Shared Function DecodeBase64ToBytes(ByVal strData As String) As Byte()
|
||
Return System.Convert.FromBase64String(strData.Replace(vbCrLf, vbNullString))
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : DecodeQuotedPrintable
|
||
' Purpose : Method to clean typical control translations, or all of them.
|
||
' : This should be invoked for all data coded Quoted-Printable.
|
||
' :
|
||
' Returns : Provided a raw message string block, it returns a decoded string.
|
||
' :
|
||
' NOTES : Typical cleaning involves changing "=0D" to vbCr, "=0A" to vbLf,
|
||
' : "=20" to a space, and "=3D" to "=", plus any line wrap
|
||
' : terminators at the end of lines to vbNullstring.
|
||
' :
|
||
' : A StringBuilder object will be used, which will very quickly
|
||
' : do a replacement of all control code translations using fewer
|
||
' : resources, and what resources that are used will be instantly
|
||
' : flushed when the method exits.
|
||
'*******************************************************************************
|
||
Public Shared Function DecodeQuotedPrintable(ByVal Message As String, Optional ByVal QuickClean As Boolean = False) As String
|
||
'set up StringBuilder object with data stripped of any line continuation tags
|
||
Dim Msg As New StringBuilder(Message.Replace("=" & vbCrLf, vbNullString))
|
||
|
||
If QuickClean Then 'perform a quick clean (clean up common basics)
|
||
Return Msg.Replace("=" & vbCrLf, vbNullString).Replace("=0D", vbCr).Replace("=0A", _
|
||
vbLf).Replace("=20", " ").Replace("=3D", "=").ToString
|
||
Else 'perform total cleaning
|
||
'store 2-character hex values that require a leading "0"
|
||
Dim HxData As String = "X0102030405060708090A0B0C0D0E0F"
|
||
For Idx As Integer = 1 To &HF 'initially process codes 1-15, which require a leading zero
|
||
Msg.Replace("=" & Mid(HxData, Idx << 1, 2), Chr(Idx)) 'replace hex data with single character code (SHIFT is faster)
|
||
Next
|
||
For idx As Integer = &H10 To &HFF 'process the whole 8-bit extended ASCII gambit
|
||
Msg.Replace("=" & Hex(idx), Chr(idx)) 'replace hex data with single character code
|
||
Next
|
||
Return Msg.ToString 'return result string
|
||
End If
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : DecodeBinHex
|
||
' Purpose : Decode a provided raw email message string that is encoded to BinHex.
|
||
' :
|
||
' Returns : Decoded String
|
||
' :
|
||
' NOTES : note that the lone vbCrLf at the end of lines is filtered out.
|
||
'*******************************************************************************
|
||
Public Shared Function DecodeBinHex(ByVal StrData As String) As Byte()
|
||
Dim Src() As Byte = Encoding.UTF8.GetBytes(StrData.Replace(vbCrLf, vbNullString).ToUpper)
|
||
Dim Result() As Byte 'init output buffer
|
||
ReDim Result(UBound(Src) \ 2) 'set initial dimension to 1024 bytes (includes offset 0)
|
||
Dim Index As Integer = 0 'init index for Result() array
|
||
|
||
For Idx As Integer = 0 To UBound(Src) Step 2 'scan the string, 2 hex characters at a time
|
||
Dim CL As Integer = Src(Idx) - 48 'Convert "0" - "F" to 0-F
|
||
If CL > 10 Then CL -= 7
|
||
Dim CR As Integer = Src(Idx + 1) - 48 'do the same for the right hex digit
|
||
If CR > 10 Then CR -= 7
|
||
If Index > UBound(Result) Then
|
||
ReDim Preserve Result(Index + 255) 'bump by 256 (allow for Index offset)
|
||
End If
|
||
Result(Index) = CByte(CL * 16 + CR) 'stuff byte value
|
||
Index += 1 'bump index
|
||
Next
|
||
ReDim Preserve Result(Index - 1) 'set array to final size
|
||
Return Result 'return the final result
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : TextNeedsEncoding
|
||
' Purpose : Determine if HTML text, Rich Text, or Plain Text requires
|
||
' : 8-bit code translation to 7-bit Quoted-Printable tags.
|
||
' :
|
||
' Returns : Provided a source string, it returns a boolena flag.
|
||
' : If the returned value is true, the source contains 8-bit data
|
||
' : and will be encoded by server.
|
||
' :
|
||
' NOTES : If text data contains 8-bit values, the default .NET
|
||
' : SMTP processor will force this code to be encoded to Base64,
|
||
' : even if only a single byte is 8-bit.
|
||
' :
|
||
' : To avoid this, the Force7BitHtml() method can be invoked on
|
||
' : HTML text to ensure that it is 7-bit encoded so that it can
|
||
' : be processed as Quoted-Printable or as 7Bit. The ForceQuotedPrintable()
|
||
' : method performs essential conversions for non-HTML text, but this
|
||
' : would be best served in Attachments and Alternate Views.
|
||
'*******************************************************************************
|
||
Public Shared Function TextNeedsEncoding(ByVal Message As String) As Boolean
|
||
Dim Byt() As Byte = Encoding.UTF8.GetBytes(Message) 'convert message to byte array
|
||
For Each B As Byte In Byt
|
||
If CBool(B And &H80) Then Return True
|
||
Next
|
||
Return False
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : Force7BitHtml
|
||
' Purpose : Method to convert 8-bit code in an HTML message to 7-bit.
|
||
' :
|
||
' Returns : Provided a string containing HTML code, it will return a string
|
||
' : containing HTML code that does not have any 8-bit data embedded.
|
||
' :
|
||
' NOTES : If any characters in an HTML text string are 8-bit (values
|
||
' : greater than 127), then they are converted into a special
|
||
' : 7-bit HTML Entity Number, For Example, code 149 (•) is an 8-bit
|
||
' : value that can be changed to HTML "•", which will ensure
|
||
' : that it will still be displayed on the HTML page, but the HTML
|
||
' : souce code will no longer carry an actual 8-bit value. If such
|
||
' : code had not been corrected, the encoding of the data would be
|
||
' : forced to change from quoted-printable to Base64, because that
|
||
' : would be the only way the email processor could guarantee that
|
||
' : the email text was fully intact.
|
||
'*******************************************************************************
|
||
Public Shared Function Force7BitHtml(ByVal HtmlSource As String) As String
|
||
Dim Sb As New StringBuilder 'set up string builder for appending data
|
||
For Idx As Integer = 1 To Len(HtmlSource)
|
||
Dim C As Integer = AscW(Mid(HtmlSource, Idx, 1)) 'get a single character from the source
|
||
Select Case C 'check each character
|
||
Case Is > &H7F, Is < 0 'if 8-bit or unicode code
|
||
Sb.Append("&#" & C.ToString & ";") 'convert to 7-bit HTML ecoder
|
||
Case Else
|
||
Sb.Append(ChrW(C)) 'else save text regardless
|
||
End Select
|
||
Next
|
||
Return Sb.ToString
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : ForceQuotedPrintable
|
||
' Purpose : Force 8-bit code in a text message to 7-bit, without data loss.
|
||
' :
|
||
' Returns : Provided a source string that contains 8-bit data, the 8-bit
|
||
' : data is converted to Hex-Tags, and the returned string is 7-bit.
|
||
' :
|
||
' NOTES : if any characters in a text string are 8-bit (values greater
|
||
' : than 127), then they are converted into special 7-bit tags.
|
||
' : For Example, code 149 (•) is an 8-bit value that can be changed
|
||
' : to hex "=95", which will ensure that it will still be displayed
|
||
' : in the text, but the text data will no longer carry an actual
|
||
' : of the data would be forced to change from quoted-printable or 7bit
|
||
' : to Base64, because that would be the only way the email processor
|
||
' : Base64, because that would be the only way the email processor
|
||
' : could guarantee that the email text was fully intact. However,
|
||
' : you will have to use the DecodeQuotedPrintable() method to convert
|
||
' : it back to its original text form.
|
||
' :
|
||
' : The Encoded text will begin with "=00". Because unencoded null codes
|
||
' : are not permitted in email data, you can use this to instantly
|
||
' : determine on the receiving end that this code will need to be
|
||
' : processed by DecodeQuotedPrintable() a second time (if initially
|
||
' : encoded as Quoted-Printable). A second pass would be required,
|
||
' : because if this translated code was afterward encoded as Quoted-
|
||
' : Printable, and all the "=xx" byte-translations, would be
|
||
' : reinterpreted as "=3Dxx", which DecodeQuotedPrintable() would
|
||
' : convert back to "=xx", so passing through a second time would
|
||
' : properly convert the additional encoding. Further, by checking the
|
||
' : text startiing with "=00", you would know that you would need to
|
||
' : double-decode the text. Also, you would want to initially skip this
|
||
' : initial tag when passing it the second time to DecodeQuotedPrintable():
|
||
' :
|
||
' : Dim Result As String = DecodeQuotedPrintable(Message) 'initially decode Quoted-Printable text
|
||
' : If VB.Left(Result, 3) = "=00" Then 'tagged as pre-encoded?
|
||
' : Return DecodeQuotedPrintable(Mid(Result, 4)) 'yes, so decode again and return, less initial null byte
|
||
' : Else
|
||
' : Return Result 'otherwise, return result of decoding
|
||
' : End If
|
||
'*******************************************************************************
|
||
Public Shared Function ForceQuotedPrintable(ByVal Message As String) As String
|
||
Dim Byt() As Byte = Encoding.UTF8.GetBytes(Message) 'convert message to byte array
|
||
Dim Sb As New StringBuilder("=00") 'set up string builder for appending data
|
||
For Each B As Byte In Byt
|
||
Select Case B 'check each byte
|
||
Case Is > &H7F 'if 8-bit code
|
||
Sb.Append("=" & Hex(B)) 'convert to 7-bit tag
|
||
Case Else
|
||
Sb.Append(Chr(B)) 'else save text regardless
|
||
End Select
|
||
Next
|
||
Return Sb.ToString
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : QConvertHTML2Text
|
||
' Purpose : Short-Form Convert HTML formatted text to plain text
|
||
' :
|
||
' Returns : Provided a simple HTML source string, it will return a Plain Text
|
||
' : string with HTML code removed.
|
||
'*******************************************************************************
|
||
Public Shared Function QConvertHTML2Text(ByVal HTMLText As String) As String
|
||
Return RegularExpressions.Regex.Replace(HTMLText.Replace(" ", " ").Replace(""", """").Replace("'", _
|
||
"'"), "<[^>]*>", "").Replace("<", "<").Replace(">", ">").Replace("&", "&").Replace(";;", ";")
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : ConvertHTML2Text
|
||
' Purpose : Convert HTML formatted text to plain text
|
||
' :
|
||
' Returns : Provided a complex HTML string, it will return a Plain Text string
|
||
' : with all HTML codes and formatting removed from it.
|
||
' :
|
||
' NOTE : Numerous of these conversions will convert the text to 8-bit,
|
||
' : though most of these sysmbols will not be encountered in most
|
||
' : HTML documents we produce. But regardless of that, if you wish
|
||
' : to make this conversion the main body message of an email, you
|
||
' : may have to further convert this using ForceQuotedPrintable()
|
||
' : to maintain Quoted-Printable encoding and avoid Base64, even
|
||
' : though this is typically not an issue. However, some few really
|
||
' : primitive email readers, typically those that simply allow you
|
||
' : to preview email messages, without fully loading them, will not
|
||
' ' know how to support Base64, or will not bother with it, but simply
|
||
' : display the raw data. RFC 2045 requires email handlers to support it.
|
||
'*******************************************************************************
|
||
Public Shared Function ConvertHTML2Text(ByVal HTMLText As String) As String
|
||
'instantiate an initially blank StringBuilder object
|
||
Dim Sb As New StringBuilder()
|
||
|
||
'first remove leading whitespace of each line and append the result to the StringBuilder
|
||
Dim ary() As String = Split(HTMLText, vbCrLf)
|
||
For Each S As String In ary
|
||
Sb.Append(S.TrimStart(Chr(9), " "c))
|
||
Next
|
||
|
||
'replace reserved entities (except <, >, and &)
|
||
Sb.Replace(""", """").Replace("'", "'").Replace(" ", " ")
|
||
|
||
'replace HTML paragraph, line breaks, and table entry terminators with vbCrLf
|
||
Sb.Replace("<p>", vbCrLf).Replace("<P>", vbCrLf).Replace("</p>", vbCrLf).Replace("</P>", vbCrLf).Replace("<br>", _
|
||
vbCrLf).Replace("<BR>", vbCrLf).Replace("</td>", vbCrLf).Replace("</TD>", vbCrLf)
|
||
|
||
'replace ISO 8859-1 Symbols (160-255). Note that any matches will make the text 8-bit
|
||
Sb.Replace("¡", "¡").Replace("¢", "¢").Replace("£", "£").Replace("¤", _
|
||
"¤").Replace("¥", "¥").Replace("¦", "¦").Replace("§", "§").Replace("¨", _
|
||
"¨").Replace("©", "©").Replace("ª", "ª").Replace("«", "«").Replace("¬", _
|
||
"¬").Replace("­", "-").Replace("®", "®").Replace("¯", "¯").Replace("°", _
|
||
"°").Replace("±", "±").Replace("²", "²").Replace("³", "³").Replace("´", _
|
||
"´").Replace("µ", "µ").Replace("¶", "¶").Replace("·", "•").Replace("¸", _
|
||
"¸").Replace("¹", "¹").Replace("º", "º").Replace("»", "»").Replace("¼", _
|
||
"¼").Replace("½", "½").Replace("¾", "¾").Replace("¿", "¿").Replace("×", _
|
||
"×").Replace("÷", "÷")
|
||
|
||
'replace ISO 8859-1 characters. Note that any matches will make the text 8-bit
|
||
Sb.Replace("À", "À").Replace("Á", "Á").Replace("Â", "Â").Replace("Ã", "Ã").Replace("Ä", _
|
||
"Ä").Replace("Å", "Å").Replace("Æ", "Æ").Replace("Ç", "Ç").Replace("È", _
|
||
"È").Replace("É", "É").Replace("Ê", "Ê").Replace("Ë", "Ë").Replace("Ì", _
|
||
"Ì").Replace("Í", "Í").Replace("Î", "Î").Replace("Ï", "Ï").Replace("Ð", _
|
||
"Ð").Replace("Ñ", "Ñ").Replace("Ò", "Ò").Replace("Ó", "Ó").Replace("Ô", _
|
||
"Ô").Replace("Õ", "Õ").Replace("Ö", "Ö").Replace("Ø", "Ø").Replace("Ù", _
|
||
"Ù").Replace("Ú", "Ú").Replace("Û", "Û").Replace("Ü", "Ü").Replace("Ý", _
|
||
"Ý").Replace("Þ", "Þ").Replace("ß", "ß").Replace("à", "à").Replace("á", _
|
||
"á").Replace("â", "â").Replace("ã", "ã").Replace("ä", "ä").Replace("å", _
|
||
"å").Replace("æ", "æ").Replace("ç", "ç").Replace("è", "è").Replace("é", _
|
||
"é").Replace("ê", "ê").Replace("ë", "ë").Replace("ì", "ì").Replace("í", _
|
||
"í").Replace("î", "î").Replace("ï", "ï").Replace("ð", "ð").Replace("ñ", _
|
||
"ñ").Replace("ò", "ò").Replace("ó", "ó").Replace("ô", "ô").Replace("õ", _
|
||
"õ").Replace("ö", "ö").Replace("ø", "ø").Replace("ù", "ù").Replace("ú", _
|
||
"ú").Replace("û", "û").Replace("ü", "ü").Replace("ý", "ý").Replace("þ", _
|
||
"þ").Replace("ÿ", "ÿ")
|
||
|
||
'replace Math Symbols Supported by HTML. Note that any matches will make the text 8-bit
|
||
Sb.Replace("∀", "∀").Replace("∂", "∂").Replace("∃", "∃").Replace("∅", "∅").Replace("∇", _
|
||
"∇").Replace("∈", "∈").Replace("∉", "∉").Replace("∋", "∋").Replace("∏", _
|
||
"∏").Replace("∑", "∑").Replace("−", "−").Replace("∗", "∗").Replace("√", _
|
||
"√").Replace("∝", "∝").Replace("∞", "∞").Replace("∠", "∠").Replace("∧", _
|
||
"∧").Replace("∨", "∨").Replace("∩", "∩").Replace("∪", "∪").Replace("∫", _
|
||
"∫").Replace("∴", "∴").Replace("∼", "∼").Replace("≅", "≅").Replace("≈", _
|
||
"≈").Replace("≠", "≠").Replace("≡", "≡").Replace("≤", "≤").Replace("≥", _
|
||
"≥").Replace("⊂", "⊂").Replace("⊃", "⊃").Replace("⊄", "⊄").Replace("⊆", _
|
||
"⊆").Replace("⊇", "⊇").Replace("⊕", "⊕").Replace("⊗", "⊗").Replace("⊥", _
|
||
"⊥").Replace("⋅", "⋅")
|
||
|
||
'replace Greek Letters Supported by HTML. Note that any matches will make the text 8-bit
|
||
Sb.Replace("Α", "Α").Replace("Β", "Β").Replace("Γ", "Γ").Replace("Δ", "Δ").Replace("Ε", _
|
||
"Ε").Replace("Ζ", "Ζ").Replace("Η", "Η").Replace("Θ", "Θ").Replace("Ι", _
|
||
"Ι").Replace("Κ", "Κ").Replace("Λ", "Λ").Replace("Μ", "Μ").Replace("Ν", _
|
||
"Ν").Replace("Ξ", "Ξ").Replace("Ο", "Ο").Replace("Π", "Π").Replace("Ρ", _
|
||
"Ρ").Replace("Σ", "Σ").Replace("Τ", "Τ").Replace("Υ", "Υ").Replace("Φ", _
|
||
"Φ").Replace("Χ", "Χ").Replace("Ψ", "Ψ").Replace("Ω", "Ω").Replace("α", _
|
||
"α").Replace("β", "β").Replace("γ", "γ").Replace("δ", "δ").Replace("ε", _
|
||
"ε").Replace("ζ", "ζ").Replace("η", "η").Replace("θ", "θ").Replace("ι", _
|
||
"ι").Replace("κ", "κ").Replace("λ", "λ").Replace("μ", "μ").Replace("ν", _
|
||
"ν").Replace("ξ", "ξ").Replace("ο", "ο").Replace("π", "π").Replace("ρ", _
|
||
"ρ").Replace("ς", "ς").Replace("σ", "σ").Replace("τ", "τ").Replace("υ", _
|
||
"υ").Replace("φ", "φ").Replace("χ", "χ").Replace("ψ", "ψ").Replace("ω", _
|
||
"ω").Replace("ϑ", "ϑ").Replace("ϒ", "ϒ").Replace("ϖ", "ϖ")
|
||
|
||
'replace Other Entities Supported by HTML. Note that any matches will make the text 8-bit
|
||
Sb.Replace("Œ", "Œ").Replace("œ", "œ").Replace("Š", "Š").Replace("š", "š").Replace("Ÿ", _
|
||
"Ÿ").Replace("ƒ", "ƒ").Replace("ˆ", "ˆ").Replace("˜", "˜").Replace(" ", _
|
||
" ").Replace(" ", " ").Replace(" ", " ").Replace("–", "–").Replace("—", _
|
||
"—").Replace("‘", "‘").Replace("’", "’").Replace("‚", "‚").Replace("“", _
|
||
" ").Replace("”", " ").Replace("„", "„").Replace("†", "†").Replace("‡", _
|
||
"‡").Replace("•", "•").Replace("…", "…").Replace("‰", "‰").Replace("′", _
|
||
"′").Replace("″", "″").Replace("‹", "‹").Replace("›", "›").Replace("‾", _
|
||
"‾").Replace("€", "€").Replace("™", "™").Replace("←", "←").Replace("↑", _
|
||
"↑").Replace("→", "→").Replace("↓", "↓").Replace("↔", "↔").Replace("↵", _
|
||
"↵").Replace("⌈", "⌈").Replace("⌉", "⌉").Replace("⌊", "⌊").Replace("⌋", _
|
||
"⌋").Replace("◊", "◊").Replace("♠", "♠").Replace("♣", "♣").Replace("♥", _
|
||
"♥").Replace("♦", "♦")
|
||
|
||
'replace special ASCII coding entities that were not captured by the above. Note that values > 127 will make the text 8-bit
|
||
For Idx As Integer = 1 To 255 'See www.w3schools.com/tags/ref_entities.asp
|
||
Sb.Replace("&#" & Idx.ToString & ";", Chr(Idx)) 'replace most common numeric entities
|
||
Next
|
||
|
||
'Ensure header definitions are followed by vbCrLf
|
||
Dim NewText As String = RegularExpressions.Regex.Replace(Sb.ToString(), "</H[^>]*>", vbCrLf)
|
||
|
||
'Also seek out other Unicode encoded number entities not covered by the above and individually update them
|
||
Dim Idy As Integer = InStr(NewText, "&#") 'check for a numeric entity
|
||
Do While Idy <> 0 'loop as long as we find one
|
||
Dim Idz As Integer = InStr(Idy, NewText, ";") 'find terminating semicolon
|
||
Dim S As String = Mid(NewText, Idy, Idz - Idy + 1) 'grab expression
|
||
RegularExpressions.Regex.Replace(NewText, S, Chr(CInt(Mid(S, 3, Len(S) - 3)))) 'replace expression
|
||
InStr(Idy + 1, NewText, "&#")
|
||
Loop
|
||
|
||
'strip remaining HTML text tags, replace < and > placeholders, convert ampersand, replace ;; with ;, then return result
|
||
Return RegularExpressions.Regex.Replace(NewText, "<[^>]*>", "").Replace("<", _
|
||
"<").Replace(">", ">").Replace("&", "&").Replace(";;", ";")
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Enum MediaTypes: Structure used by GetMediaType
|
||
'*******************************************************************************
|
||
Public Enum MediaTypes As Integer
|
||
ApplicationOctet ' 0 = Integer Value
|
||
ApplicationPdf ' 1
|
||
ApplicationRtf ' 2
|
||
ApplicationSoap ' 3
|
||
ApplicationZip ' 4
|
||
ImageGif ' 5
|
||
ImageJpeg ' 6
|
||
ImageTiff ' 7
|
||
TextHtml ' 8
|
||
TextPlain ' 9
|
||
TextRich '10
|
||
TextXml '11
|
||
End Enum
|
||
|
||
'*******************************************************************************
|
||
' Function Name : GetMediaType
|
||
' Purpose : Provide easy access to System.Net.Mime.MediaTypes text
|
||
' :
|
||
' Returns : provided a MediaTypes enumeration value, a string representing
|
||
' : the selected type will be returned.
|
||
'*******************************************************************************
|
||
Public Shared Function GetMediaType(ByVal MediaType As MediaTypes) As String
|
||
Select Case MediaType
|
||
Case MediaTypes.ApplicationPdf
|
||
Return "application/pdf"
|
||
Case MediaTypes.ApplicationRtf
|
||
Return "application/rtf"
|
||
Case MediaTypes.ApplicationSoap
|
||
Return "application/soap+xml"
|
||
Case MediaTypes.ApplicationZip
|
||
Return "application/zip"
|
||
Case MediaTypes.ImageGif
|
||
Return "image/gif"
|
||
Case MediaTypes.ImageJpeg
|
||
Return "image/jpeg"
|
||
Case MediaTypes.ImageTiff
|
||
Return "image/tiff"
|
||
Case MediaTypes.TextHtml
|
||
Return "text/html"
|
||
Case MediaTypes.TextPlain
|
||
Return "text/plain"
|
||
Case MediaTypes.TextRich
|
||
Return "text/richtext"
|
||
Case MediaTypes.TextXml
|
||
Return "text/xml"
|
||
Case Else
|
||
Return "application/octet-stream"
|
||
End Select
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Enum TransferEncodings: Structure used by GetTransferEncoding
|
||
'*******************************************************************************
|
||
Public Enum TransferEncodings As Integer
|
||
QuotedPrintable ' 0 = Integer value
|
||
Base64 ' 1
|
||
SevenBit ' 2
|
||
End Enum
|
||
|
||
'*******************************************************************************
|
||
' Function Name : GetTransferEncoding
|
||
' Purpose : Provide easy access to System.Net.Mime.TransferEncoding data
|
||
' :
|
||
' Returns : Provided a TransferEncodings value, a TransferEncoding value
|
||
' : is returned.
|
||
'*******************************************************************************
|
||
Public Shared Function GetTransferEncoding(ByVal TransferEncoding As TransferEncodings) As System.Net.Mime.TransferEncoding
|
||
Return DirectCast(TransferEncoding, System.Net.Mime.TransferEncoding)
|
||
End Function
|
||
|
||
'==========================================================================
|
||
'==========================================================================
|
||
|
||
'*******************************************************************************
|
||
' Function Name : GetEmailInfo
|
||
' Purpose : Break email down into its component parts.
|
||
' :
|
||
' Returns : EmailInfo object with component parts of email broken down.
|
||
' :
|
||
' NOTES : This method uses classes EmailItems and EmailInfo.
|
||
' : The Message Body, and each AlternnateView or Attachment are
|
||
' : contained within EmailItem objects within the EmailIngo object.
|
||
' :
|
||
' : An EmailItem contains fields for FROM, TO, SUBJECT, Content-Type,
|
||
' : a flag indicating if the ContentTypeData is a filename or if it is
|
||
' : text formatting, content-transfer-encoding data, and the raw encoded,
|
||
' : data, whether it is a message or binary information. If the content-
|
||
' : transfer encoding is set to "base64", the data should be decoded
|
||
' : using the DecodeBase64() method. If it is "quoted-printable", the
|
||
' : data should be decoded using DecodeQuotedPrintable(). If it is
|
||
' : "7bit", it is 7-bit data and does not need to be decoded.
|
||
'*******************************************************************************
|
||
Public Shared Function GetEmailInfo(ByVal MailMessage As String) As EmailInfo
|
||
Dim Info As New EmailInfo 'structure to hold breakdown of email
|
||
Dim Ary() As String = Split(MailMessage, vbCrLf) 'break full email into lines
|
||
Dim Idx As Integer = 0 'index into Ary()
|
||
Dim MX As Integer = UBound(Ary) + 1 'find end if list+1
|
||
Dim Boundaries As New Collections.Generic.List(Of String) 'boundary definitions
|
||
|
||
Dim IsMultiPart As Boolean = False 'true if we have multiple parts
|
||
Dim SeekingEncoding As Boolean = False 'true if we are looking for encoding
|
||
Dim BuildingDataBlock As Boolean = False 'true if we are building a data block
|
||
Dim HaveMessageBody As Boolean = False 'true if we have the message body defined
|
||
|
||
Dim ContentType As String = vbNullString 'hold last-defined Content Type
|
||
Dim ContentTypeIsName As Boolean = False 'true of Content Type specified a file
|
||
Dim ContentTypeData As String = vbNullString 'if block isan attachment
|
||
Dim ContentEncoding As String = vbNullString 'hold last-defined Content Transfer Encoding
|
||
Dim ContentBody As String = vbNullString 'block data accumulator
|
||
'-----------------------------------------------------------
|
||
Dim Inheader As Integer = 4 'flag for gathering To, From, Date, Subject
|
||
Do
|
||
Dim S As String = Ary(Idx) 'grab a line of data from the email
|
||
'
|
||
' check for important header items
|
||
'
|
||
If CBool(Len(S)) AndAlso CBool(Inheader) Then 'if we are currently in the header...
|
||
Dim I As Integer = InStr(S, ":") 'find field delimiter
|
||
If CBool(I) Then 'found one?
|
||
If VB.Right(S, 1) = ";" Then 'line continues?
|
||
Idx += 1 'yes, so bump index
|
||
S &= Ary(Idx).Trim(Chr(9), " "c) 'append next line next line
|
||
End If
|
||
Select Case LCase(VB.Left(S, I)) 'yes, check for one of 4 fields
|
||
Case "from:" 'Found FROM field
|
||
Info.FromData = Trim(Mid(S, I + 1)) 'stuff to structure
|
||
Inheader -= 1 'drop 1 from flag
|
||
Case "to:" 'Found TO field
|
||
Info.ToData = Trim(Mid(S, I + 1)) 'stuff to structure
|
||
Inheader -= 1 'drop 1 from flag
|
||
Case "date:" 'Found DATE field
|
||
Info.DateData = Trim(Mid(S, I + 1)) 'stuff to structure
|
||
Inheader -= 1 'drop 1 from flag
|
||
Case "subject:" 'Found SUBJECT field
|
||
Info.SubjectData = Trim(Mid(S, I + 1)) 'stuff to structure
|
||
Inheader -= 1 'drop 1 from flag
|
||
End Select
|
||
End If
|
||
If Not CBool(Inheader) Then 'if InHeader flag is zero
|
||
SeekingEncoding = True 'start looking for a Content-Transfer-Encoding field
|
||
S = vbNullString 'purge current data
|
||
End If
|
||
End If
|
||
'-------------------------------------------------------
|
||
' check for boundaries
|
||
'-------------------------------------------------------
|
||
If CBool(Len(S)) AndAlso CBool(Boundaries.Count) Then 'check any defined boundaries
|
||
For Idy As Integer = 0 To Boundaries.Count - 1
|
||
If CBool(InStr(S, Boundaries.Item(Idy), CompareMethod.Text)) Then
|
||
If BuildingDataBlock Then
|
||
Dim Itm As New EmailItem 'create a new item
|
||
Itm.ContentType = ContentType 'store content type
|
||
Itm.ContentTypeData = ContentTypeData 'save filename or character set
|
||
Itm.ContentTypeDataIsFilename = ContentTypeIsName 'save flag indicating if Attachment
|
||
Itm.ContentEncoding = ContentEncoding 'store encoding
|
||
Itm.ContentBody = ContentBody 'store data
|
||
ContentBody = vbNullString 'reset accumulator
|
||
If HaveMessageBody Then 'already have a message body?
|
||
If ContentTypeIsName Then 'if an attachment
|
||
Info.Attachments.Add(Itm) 'add an attachment
|
||
Else 'otherwise an alternate view
|
||
Info.AlternateViews.Add(Itm)
|
||
End If
|
||
Else
|
||
Info.MessageBody = Itm 'else stuff new item to message body
|
||
HaveMessageBody = True 'indicate we now have a message body
|
||
End If
|
||
ContentTypeData = vbNullString 'reset filename/charset
|
||
BuildingDataBlock = False 'turn off building flag
|
||
End If
|
||
SeekingEncoding = True 'turn block seeing on again
|
||
S = vbNullString 'purge current data
|
||
Exit For
|
||
End If
|
||
Next
|
||
End If
|
||
'-------------------------------------------------------
|
||
' build data block
|
||
'-------------------------------------------------------
|
||
If BuildingDataBlock Then
|
||
ContentBody &= S & vbCrLf 'add a line to content data
|
||
End If
|
||
'-------------------------------------------------------
|
||
' if seeking encoding
|
||
'-------------------------------------------------------
|
||
If CBool(Len(S)) AndAlso SeekingEncoding Then 'are we seeking TCE?
|
||
Dim I As Integer = InStr(S, ":") 'yes, check for field delimiter
|
||
If CBool(I) Then 'did we find one?
|
||
Select Case LCase(VB.Left(S, I)) 'yes, check for types
|
||
'=======================================================
|
||
Case "content-type:" 'Content type?
|
||
ContentType = Mid(S, I + 1).Trim(Chr(9), " "c) 'yes, so grab data
|
||
If VB.Right(S, 1) = ";" Then 'more to add?
|
||
Idx += 1 'yes, so bump index
|
||
ContentType &= Ary(Idx).Trim(Chr(9), " "c) 'grab next line
|
||
End If
|
||
ContentTypeIsName = False 'init flag specifying a file as false
|
||
Dim sbAry() As String = Split(ContentType, ";") 'now check the content type data
|
||
ContentType = sbAry(0) 'keep first part for ContentType
|
||
If StrComp(VB.Left(sbAry(0), 10), "multipart/", CompareMethod.Text) = 0 Then
|
||
'multipart, so grab second parameter (boundary definition), and strip any quotes
|
||
Dim Bnd As String = Trim(Mid(sbAry(1), InStr(sbAry(1), "=") + 1)).Replace("""", vbNullString)
|
||
Boundaries.Add(Bnd) 'and add a boundary
|
||
ElseIf StrComp(VB.Left(sbAry(1), 5), "name=", CompareMethod.Text) = 0 Then
|
||
ContentTypeIsName = True 'attachment if a filename specified (otherwise a view)
|
||
sbAry = Split(sbAry(1), "=") 'multipart, so grab second parameter
|
||
'get second part of second parameter (filename definition)
|
||
ContentTypeData = sbAry(1).Trim().Replace("""", vbNullString) 'strip any quotes
|
||
Else
|
||
ContentTypeData = sbAry(1) 'AlternateView, so stuff display character set
|
||
End If
|
||
'===================================================
|
||
Case "content-transfer-encoding:"
|
||
ContentEncoding = Mid(S, I + 1).Trim(Chr(9), " "c) 'yes, so grab data
|
||
SeekingEncoding = False 'turn off seeking flag
|
||
BuildingDataBlock = True 'turn on building data block flag
|
||
Idx += 1 'bump to skip required following blank line
|
||
End Select
|
||
End If
|
||
End If
|
||
Idx += 1 'bump array index
|
||
Loop While Idx < MX
|
||
'-----------------------------------------------------------
|
||
Return Info 'return with filled data block
|
||
End Function
|
||
End Class
|
||
|
||
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||
|
||
'*******************************************************************************
|
||
' Class Name : EmailItem (used by EmailInfo class)
|
||
' Purpose : Stores structure of an email block
|
||
'*******************************************************************************
|
||
Public Class EmailItem
|
||
Public ContentType As String = vbNullString 'CONTENT-TYPE data
|
||
Public ContentTypeData As String = vbNullString 'filename or text encoding
|
||
Public ContentTypeDataIsFilename As Boolean = False 'True if ContentTypeData specifies a filename
|
||
Public ContentEncoding As String = vbNullString 'CONTENT-TRANSFER-ENCODING data
|
||
Public ContentBody As String = vbNullString 'raw data of block
|
||
End Class
|
||
|
||
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
|
||
|
||
'*******************************************************************************
|
||
' Class Name : EmailInfo (used by GetEmailInfo method)
|
||
' Purpose : Store component parts of an Email
|
||
'*******************************************************************************
|
||
Public Class EmailInfo
|
||
Public FromData As String = vbNullString 'FROM:
|
||
Public ToData As String = vbNullString 'TO:
|
||
Public DateData As String = vbNullString 'DATE:
|
||
Public SubjectData As String = vbNullString 'SUBJECT:
|
||
Public MessageBody As EmailItem 'contents of message body
|
||
Public AlternateViews As New Collections.Generic.List(Of EmailItem) 'list of alternate views
|
||
Public Attachments As New Collections.Generic.List(Of EmailItem) 'list of attachments
|
||
End Class
|