VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CMailHeader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"Bcc"
Attribute VB_Ext_KEY = "Member1" ,"Cc"
Attribute VB_Ext_KEY = "Member2" ,"From"
Attribute VB_Ext_KEY = "Member3" ,"MailTo"
Attribute VB_Ext_KEY = "Member4" ,"ReplyTo"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'programmed by ShareVB
'gestion de l'entête d'un mail pour la partie (de l'entête) non MIME

Option Explicit
Option Compare Text

Private Declare Function quoted_printable_decode_to_string Lib "MIMECode.dll" Alias "_quoted_printable_decode@8" (ByVal dest As String, ByVal src As String) As Long

'variables locales de stockage des valeurs de propriétés
Private mvarOriginationDate As CMailDate 'copie locale
Private mvarSubject As CSubject 'copie locale
Private mvarMessageID As CMessageID 'copie locale
Private mvarInReplyTo As CMessageID 'copie locale
Private mvarBcc As Bcc
Private mvarCc As Cc
Private mvarFrom As From
Private mvarMailTo As MailTo
Private mvarReplyTo As ReplyTo
Private mvarXPriority As CPriority
Private mvarNotify As CNotify

'==================================================
'propriétés
'==================================================

Public Property Get ReadNotification() As CNotify
    Set ReadNotification = mvarNotify
End Property

Public Property Get XPriority() As CPriority
    Set XPriority = mvarXPriority
End Property

Public Property Get InReplyTo() As CMessageID
    Set InReplyTo = mvarInReplyTo
End Property

Public Property Get ReplyTo() As ReplyTo
    If mvarReplyTo Is Nothing Then
        Set mvarReplyTo = New ReplyTo
    End If

    Set ReplyTo = mvarReplyTo
End Property

Public Property Get MailTo() As MailTo
    If mvarMailTo Is Nothing Then
        Set mvarMailTo = New MailTo
    End If

    Set MailTo = mvarMailTo
End Property

Public Property Get From() As From
    If mvarFrom Is Nothing Then
        Set mvarFrom = New From
    End If

    Set From = mvarFrom
End Property

Public Property Get Cc() As Cc
    If mvarCc Is Nothing Then
        Set mvarCc = New Cc
    End If

    Set Cc = mvarCc
End Property

Public Property Get Bcc() As Bcc
    If mvarBcc Is Nothing Then
        Set mvarBcc = New Bcc
    End If

    Set Bcc = mvarBcc
End Property

Public Property Get Subject() As CSubject
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.Subject
    Set Subject = mvarSubject
End Property

Public Property Get MessageID() As CMessageID
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.MessageID
    Set MessageID = mvarMessageID
End Property

Public Property Get OriginationDate() As CMailDate
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.OriginationDate
    Set OriginationDate = mvarOriginationDate
End Property

'==================================================
'méthodes privées
'==================================================

'transforme les lignes à la taille maximum
Private Function Folding(ByVal szHeader As String) As String
Dim pos As Long, lastposwsp As Long, possp As Long, postab As Long, poswsp As Long, l As Long

If Len(szHeader) < 74 Then
    Folding = szHeader
Else
    szHeader = " " & szHeader
    pos = 72
    lastposwsp = 1
    l = Len(szHeader)
    Do While pos <= l
        possp = InStrRev(szHeader, " ", pos, vbBinaryCompare)
        postab = InStrRev(szHeader, vbTab, pos, vbBinaryCompare)
        
        If possp > postab Then poswsp = possp Else poswsp = postab
        
        Folding = Folding & vbTab & Trim$(Mid$(szHeader, lastposwsp + 1, poswsp - lastposwsp - 1)) & vbCrLf
        
        lastposwsp = poswsp
        pos = poswsp + 72
    Loop
    Folding = Folding & vbTab & Trim$(Mid$(szHeader, lastposwsp + 1))
End If
End Function

'remet les lignes en une seule partie
Private Function Unfolding(szHeaders As String) As String
Unfolding = Replace(szHeaders, vbCrLf & vbTab, " ")
Unfolding = Replace(Unfolding, vbCrLf & " ", " ")
End Function

'==================================================
'méthodes publiques
'==================================================

'analyse
Public Sub Parse(ByVal szHeaders As String)
Dim lszFields() As String, szField As String
Dim posval As Long, szAttr As String, szValue As String
Dim x As Long, ub As Long

szHeaders = Unfolding(szHeaders)
lszFields = Split(szHeaders, vbCrLf)

ub = UBound(lszFields)
For x = 0 To ub
    szField = lszFields(x)
    
    posval = InStr(szField, ":")
    If posval > 0 Then
        szAttr = Trim$(Mid$(szField, 1, posval - 1))
        szValue = Trim$(Mid$(szField, posval + 1))
        
        Select Case szAttr
            Case "Date"
                mvarOriginationDate.Parse szValue
            Case "From"
                mvarFrom.Parse szValue
            Case "Reply-To"
                mvarReplyTo.Parse szValue
            Case "To"
                mvarMailTo.Parse szValue
            Case "Cc"
                mvarCc.Parse szValue
            Case "Bcc"
                mvarBcc.Parse szValue
            Case "Subject"
                mvarSubject.Parse szValue
        
            Case "Message-ID"
                mvarMessageID.Parse szValue
            Case "In-Reply-To"
                mvarInReplyTo.Parse szValue
        
            Case "X-Priority"
                mvarXPriority.Parse szValue
            
            Case "Disposition-Notification-To"
                mvarNotify.Parse szValue
            Case "Return-Receipt-To"
                mvarNotify.Parse szValue
            Case "Read-Receipt-To"
                mvarNotify.Parse szValue
        End Select
    End If
Next
End Sub

Public Function Make() As String
Dim szTo As String, szCc As String, szReply As String, szSubject As String, szID As String, szInReplyTo As String, szXPriority As String, szNotify As String

Make = "Date: " & mvarOriginationDate.Make & vbCrLf
Make = Make & Folding("From: " & mvarFrom.Make) & vbCrLf

szTo = mvarMailTo.Make
'szBcc = mvarBcc.Make
szCc = mvarCc.Make
szSubject = mvarSubject.Make
szReply = mvarReplyTo.Make
szID = mvarMessageID.Make
szInReplyTo = mvarXPriority.Make
szXPriority = mvarXPriority.Make
szNotify = mvarNotify.Mail

If Len(szTo) Then Make = Make & Folding("To: " & szTo) & vbCrLf
If Len(szCc) Then Make = Make & Folding("Cc: " & szCc) & vbCrLf
'If Len(szBcc) Then Make = Make & Folding("Bcc: " & szBcc) & vbCrLf
If Len(szReply) Then Make = Make & Folding("Reply-To: " & szReply) & vbCrLf
If Len(szSubject) Then Make = Make & Folding("Subject: " & szSubject) & vbCrLf
If Len(szID) Then Make = Make & Folding("Message-ID: " & szID) & vbCrLf
If Len(szInReplyTo) Then Make = Make & Folding("In-Reply-To: " & szInReplyTo) & vbCrLf
If Len(szXPriority) Then Make = Make & Folding("X-Priority: " & szXPriority) & vbCrLf
If Len(szNotify) Then Make = Make & Folding("Disposition-Notification-To: " & szNotify) & vbCrLf
End Function


'==================================================
'constructeur et destructeur
'==================================================

Private Sub Class_Initialize()
    Set mvarSubject = New CSubject
    Set mvarOriginationDate = New CMailDate
    Set mvarReplyTo = New ReplyTo
    Set mvarMailTo = New MailTo
    Set mvarFrom = New From
    Set mvarCc = New Cc
    Set mvarBcc = New Bcc

    Set mvarMessageID = New CMessageID
    Set mvarInReplyTo = New CMessageID
    Set mvarXPriority = New CPriority
    Set mvarNotify = New CNotify
End Sub

Private Sub Class_Terminate()
    Set mvarInReplyTo = Nothing
    Set mvarMessageID = Nothing
    Set mvarXPriority = Nothing
    
    Set mvarReplyTo = Nothing
    Set mvarMailTo = Nothing
    Set mvarFrom = Nothing
    Set mvarCc = Nothing
    Set mvarBcc = Nothing
    Set mvarOriginationDate = Nothing
    Set mvarSubject = Nothing
    
    Set mvarNotify = Nothing
End Sub

