I need the below code modified to handle Internet headers that are "folded" into multiple lines per
' /* 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>
I have attached 2 sample headers (email addresses are not real); the "To:" header is the header of interest.
Basically, I need the code modified to "unfold" multiline header fields by removing CRLF when it is immediately followed by whitespace. This needs to be done BEFORE parsing the words to decode.
Thanks for any help--
Const C_SEP = " "
Const C_EQUAL = "="
Const C_QUEST = "?"
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)
' * "_" => 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)
Message.BodyPart.ContentTransferEncoding = "quoted-printable"
Message.BodyPart.ContentTransferEncoding = "base64"
Message.BodyPart.ContentTransferEncoding = "us-ascii" ' ?
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))
Set Stream = Nothing
Set Stream = Message.BodyPart.GetDecodedContentStream
Stream.Charset = encCharSet
mhdecode = Stream.ReadText
Set Stream = Nothing
mhdecode = s
Code provided by robert_schutt (Thanks again!)