' /* 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
' evaluation.
'
' Example:
' 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
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
From novice to tech pro — start learning today.
1) need to take out spacing between the encoded words:
Open in new window
2) need to retain some form of spacing (I chose 1 space):
Open in new window
The code:
Open in new window