We value your feedback.
Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
' /* Rfc 2822 2.2 Header Fields
' Header fields are lines composed of a field name, followed by a colon
' (":"), followed by a field body, and terminated by CRLF. A field
' name MUST be composed of printable US-ASCII characters (i.e.,
' characters that have values between 33 and 126, inclusive), except
' colon. A field body may be composed of any US-ASCII characters,
' except for CR and LF. However, a field body may contain CRLF when
' used in header "folding" and "unfolding" as described in section
' 2.2.3. All field bodies MUST conform to the syntax described in
' sections 3 and 4 of this standard.
' Rfc 2822 2.2.3 (Multiline header fields)
' The process of moving from this folded multiple-line representation
' of a header field to its single line representation is called
' "unfolding". Unfolding is accomplished by simply removing any CRLF
' that is immediately followed by WSP. Each header field should be
' treated in its unfolded form for further syntactic and semantic
' Subject: aaaaa<CRLF>
' <TAB or SP>aaaaa<CRLF>
Option Explicit Const C_SEP = " " Const C_EQUAL = "=" Const C_QUEST = "?" ' Sub TestAllDecode() Dim arrh: arrh = Array( _ "Test: =?utf-8?b?SWhyZSBCZXN0ZWxsdW5nIC0gVmVyc2FuZGJlc3TDpHRpZ3VuZyAtIDExMDU4OTEyNDY=?=", _ "Subject: =?utf-8?Q?Your=20Weekly=20HAR=205=2DMinute=20REALTOR=C2=AE=3A=20Posts=20for=20the=20week=20of=2003=2F06=2F2012?=", _ "To: =?utf-8?Q?Fred?= <HAR@Equity.com>" _ ) Dim strH, strW, d For Each strH In arrh d = "" For Each strW In Split(strH, C_SEP) If d <> "" Then d = d & C_SEP d = d & mhdecode(strW) Next Debug.Print d Next End Sub ' TODO: ' * "_" => space ' * first word always unencoded? ' * comments in parentheses for specific fields? Function mhdecode(ByVal s As String) As String Dim hdr As String: hdr = C_EQUAL & C_QUEST ' "=?utf-8?" Dim ftr As String: ftr = C_QUEST & C_EQUAL Dim lenS As Integer: lenS = Len(s) If Left(s, Len(hdr)) = hdr And Right(s, Len(ftr)) = ftr Then Dim p1 As Integer: p1 = InStr(Len(hdr) + 1, s, C_QUEST) If p1 > Len(hdr) + 1 And p1 < lenS - 2 Then Dim p2 As Integer: p2 = InStr(p1 + 1, s, C_QUEST) If p2 > p1 + 1 And p2 < lenS - 2 Then Dim encCharSet As String: encCharSet = Mid(s, Len(hdr) + 1, p1 - Len(hdr) - 1) Dim encType As String: encType = Mid(s, p1 + 1, p2 - p1 - 1) Dim Message: Set Message = CreateObject("CDO.Message") Select Case UCase(encType) Case "Q" Message.BodyPart.ContentTransferEncoding = "quoted-printable" Case "B" Message.BodyPart.ContentTransferEncoding = "base64" Case Else Message.BodyPart.ContentTransferEncoding = "us-ascii" ' ? End Select Dim Stream 'As ADODB.Stream Set Stream = Message.BodyPart.GetEncodedContentStream 'Set charset To base windows charset Stream.Charset = "windows-1250" Stream.WriteText Mid(s, p2 + 1, lenS - p2 - Len(ftr)) Stream.Flush Stream.Close Set Stream = Nothing Set Stream = Message.BodyPart.GetDecodedContentStream Stream.Charset = encCharSet mhdecode = Stream.ReadText Stream.Close Set Stream = Nothing End If End If Else mhdecode = s End If End Function
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Join the community of 500,000 technology professionals and ask your questions.