VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CMail"
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" ,"MailBodies"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'programmed by ShareVB
'gestion du contenu d'un Mail MIME

Option Explicit
Option Compare Text

Private Const ERROR_SUCCESS As Long = 0&

Private Const HKEY_CLASSES_ROOT As Long = &H80000000
Private Const KEY_QUERY_VALUE As Long = &H1
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByVal lpType As Long, ByRef lpData As Any, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

'détermine la meilleure méthode d'encodage pour les données passées
Private Declare Function best_encoding_method Lib "MIMECode.dll" Alias "_best_encodind_method@8" (ByVal src As Long, ByVal cb As Long) As Long

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
Private Declare Function base_64_decode_to_string Lib "MIMECode.dll" Alias "_base_64_decode@8" (ByVal dest As String, ByVal src As String) As Long

Private mvarMailHeader As CMailHeader 'copie locale
Private mvarMailHTML As CMailBody
Private mvarMailPlain As CMailBody
Private mvarMailBodies As MailBodies
Private mvarMIMEHeader As CMIMEHeader 'copie locale

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

Private Function Demangler(ByVal szMangle As String, Optional szCharset As String) As String
Dim poscharset As Long, posenc As Long, postext As Long, posend As Long
Dim szEnc As String, szEncText As String, szDecText As String, l As Long

poscharset = InStr(szMangle, "=?")
While poscharset
    posenc = InStr(poscharset + 2, szMangle, "?")
    postext = InStr(posenc + 1, szMangle, "?")
    posend = InStr(postext + 1, szMangle, "?=")
    
    szCharset = Mid$(szMangle, poscharset + 2, posenc - poscharset - 2)
    szEnc = Mid$(szMangle, posenc + 1, 1)
    
    szEncText = Mid$(szMangle, postext + 1, posend - postext - 1)
    szDecText = Space(Len(szEncText) + 1)
    If szEnc = "Q" Then
        l = quoted_printable_decode_to_string(szDecText, szEncText)
    ElseIf szEnc = "B" Then
        l = base_64_decode_to_string(szDecText, szEncText)
    End If
    szDecText = Mid$(szDecText, 1, l)
    szMangle = Mid$(szMangle, 1, poscharset - 1) & szDecText & Mid$(szMangle, posend + 2)
    poscharset = InStr(szMangle, "=?")
Wend
Demangler = szMangle
End Function

Private Function GetMIMEType(ByVal szExt As String) As String
Dim hKey As Long, ret As Long, cb As Long

ret = RegOpenKeyEx(HKEY_CLASSES_ROOT, szExt, 0&, KEY_QUERY_VALUE, hKey)
If ret = ERROR_SUCCESS Then
    cb = 256
    GetMIMEType = Space(256)
    ret = RegQueryValueEx(hKey, "Content Type", 0&, ByVal 0&, ByVal GetMIMEType, cb)
    If ret = ERROR_SUCCESS Then
        GetMIMEType = Mid$(GetMIMEType, 1, cb - 1)
    Else
        GetMIMEType = "application/octet-stream"
    End If
    RegCloseKey hKey
Else
    GetMIMEType = "application/octet-stream"
End If
End Function

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

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

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

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

Public Property Get MailBodies() As MailBodies
    If mvarMailBodies Is Nothing Then
        Set mvarMailBodies = New MailBodies
    End If

    Set MailBodies = mvarMailBodies
End Property

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

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

'analyse un contenu de mail et remplit l'objet avec
Public Sub Parse(szMail As String)
Dim szHeaders As String, szBody As String
Dim pos As Long, body As CMailBody

Dim parts() As String, ub As Long, ub2 As Long, x As Long, y As Long
Dim subparts() As String, body2 As CMailBody

pos = InStr(szMail, vbCrLf & vbCrLf)

szHeaders = Mid$(szMail, 1, pos - 1)
szHeaders = Demangler(szHeaders)

'set defaults
With mvarMIMEHeader.ContentType
    .CTType = "text"
    .CTSubType = "plain"
    .charset = "us-ascii"
End With
With mvarMIMEHeader.ContentDisposition
    .CDType = "inline"
End With
mvarMIMEHeader.ContentTransfertEncoding = "7bit"

'les entêtes
mvarMailHeader.Parse szHeaders
mvarMIMEHeader.Parse szHeaders
szHeaders = vbNullString

'le contenu qui suit séparé de l'entête par une ligne vide
With mvarMIMEHeader.ContentType
    Select Case .CTType
        'attachement seul ???
        Case "image", "video", "audio", "application"
            szBody = Mid$(szMail, pos + 4)
            Set body = New CMailBody
            body.Content = szBody
            mvarMailBodies.Add body
        'mail mail sans pièces jointes
        Case "text"
            szBody = Mid$(szMail, pos + 4)
            'texte sans mise en forme
            If .CTSubType = "plain" Then
                Set mvarMailPlain = New CMailBody
                mvarMailPlain.Content = szBody
                Set mvarMailPlain.MimeHeader = mvarMIMEHeader
            'texte HTML
            ElseIf .CTSubType = "html" Then
                Set mvarMailHTML = New CMailBody
                mvarMailHTML.Content = szBody
                Set mvarMailHTML.MimeHeader = mvarMIMEHeader
            'autre : RTF ???
            Else
                Set body = New CMailBody
                body.Content = szBody
                mvarMailBodies.Add body
            End If
        'texte avec pièces jointes
        Case "multipart"
            szBody = Mid$(szMail, pos + 2)
            'le contenu est séparé par des bornes
            parts = Split(szBody, vbCrLf & "--" & .boundary)
            
            'pour chaque partie
            ub = UBound(parts)
            For x = 1 To ub - 1
                Set body = New CMailBody
                body.Parse parts(x)
                
                'si pièce jointe
                If body.MimeHeader.ContentDisposition.CDType = "attachment" Then
                    mvarMailBodies.Add body
                Else
                    'autre contenu
                    With body.MimeHeader.ContentType
                        Select Case .CTType
                            Case "text"
                                If .CTSubType = "plain" Then
                                    If mvarMailPlain Is Nothing Then
                                        Set mvarMailPlain = body
                                    Else
                                        mvarMailPlain.Content = mvarMailPlain.Content & body.Content
                                    End If
                                ElseIf .CTSubType = "html" Then
                                    If mvarMailHTML Is Nothing Then
                                        Set mvarMailHTML = body
                                    Else
                                        mvarMailHTML.Content = mvarMailHTML.Content & body.Content
                                    End If
                                Else
                                    mvarMailBodies.Add body
                                End If
                            Case "multipart" ' textes alternatifs HTML/Plain
                                subparts = Split(body.Content, vbCrLf & "--" & body.MimeHeader.ContentType.boundary)
                    
                                ub2 = UBound(subparts)
                                For y = 1 To ub2 - 1
                                    Set body2 = New CMailBody
                                    body2.Parse subparts(y)
                                    
                                    With body2.MimeHeader.ContentType
                                        Select Case .CTType
                                            Case "text"
                                                If .CTSubType = "plain" Then
                                                    If mvarMailPlain Is Nothing Then
                                                        Set mvarMailPlain = body2
                                                    Else
                                                        mvarMailPlain.Content = mvarMailPlain.Content & body2.Content
                                                    End If
                                                ElseIf .CTSubType = "html" Then
                                                    If mvarMailHTML Is Nothing Then
                                                        Set mvarMailHTML = body2
                                                    Else
                                                        mvarMailHTML.Content = mvarMailHTML.Content & body2.Content
                                                    End If
                                                Else
                                                    mvarMailBodies.Add body2
                                                End If
                                            Case Else
                                                mvarMailBodies.Add body2
                                        End Select
                                    End With
                                Next
                            Case Else
                                mvarMailBodies.Add body
                        End Select
                    End With
                End If
            Next
    End Select
End With
End Sub

'fabrication du contenu du mail depuis le contenu de l'objet
Public Function Make() As String
Dim body As CMailBody, mh As New CMIMEHeader
Dim szMessage As String, szBoundary As String

mh.ContentTransfertEncoding = "7bit"

'le message
If mvarMailPlain Is Nothing Then
    If mvarMailHTML Is Nothing Then
        If mvarMailBodies.Count Then
            'message sans message avec attachment
            With mh.ContentType
                .CTSubType = "mixed"
                .CTType = "multipart"
                .GenerateBoundary
                
                szBoundary = vbCrLf & "--" & .boundary & vbCrLf
            End With
        End If
    Else
        If mvarMailBodies.Count Then
            'message HTML avec attachment
            With mh.ContentType
                .CTSubType = "mixed"
                .CTType = "multipart"
                .GenerateBoundary
                
                szBoundary = vbCrLf & "--" & .boundary & vbCrLf
                szMessage = szBoundary & mvarMailHTML.MimeHeader.Make & vbCrLf & mvarMailHTML.Content & vbCrLf
            End With
        Else
            'message HTML sans attachment
            Set mh = mvarMailHTML.MimeHeader
            szMessage = mvarMailHTML.Content & vbCrLf
        End If
    End If
Else
    If mvarMailHTML Is Nothing Then
        If mvarMailBodies.Count Then
            'message texte avec attachment
            With mh.ContentType
                .CTSubType = "mixed"
                .CTType = "multipart"
                .GenerateBoundary
                
                szBoundary = vbCrLf & "--" & .boundary & vbCrLf
                szMessage = szBoundary & mvarMailPlain.MimeHeader.Make & vbCrLf & mvarMailPlain.Content & vbCrLf
            End With
        Else
            'message texte sans attachment
            Set mh = mvarMailPlain.MimeHeader
            szMessage = mvarMailPlain.Content & vbCrLf
        End If
    Else
        If mvarMailBodies.Count Then
            'message texte/HTML avec attachment
            With mh.ContentType
                .CTSubType = "mixed"
                .CTType = "multipart"
                .GenerateBoundary
                
                Set body = New CMailBody
                With body.MimeHeader.ContentType
                    .CTType = "multipart"
                    .CTSubType = "alternative"
                    .GenerateBoundary
                End With
                body.MimeHeader.ContentTransfertEncoding = "7bit"
                
                szBoundary = vbCrLf & "--" & body.MimeHeader.ContentType.boundary & vbCrLf

                szMessage = vbCrLf & "--" & .boundary & vbCrLf & _
                                body.MimeHeader.Make & vbCrLf & _
                                szBoundary & _
                                    mvarMailPlain.MimeHeader.Make & vbCrLf & _
                                    mvarMailPlain.Content & _
                                szBoundary & _
                                    mvarMailHTML.MimeHeader.Make & vbCrLf & _
                                    mvarMailHTML.Content & _
                                vbCrLf & "--" & body.MimeHeader.ContentType.boundary & "--" & vbCrLf
                
                szBoundary = vbCrLf & "--" & .boundary & vbCrLf

                Set body = Nothing
            End With
        Else
            'message texte/HTML sans attachment
            With mh.ContentType
                .CTSubType = "alternative"
                .CTType = "multipart"
                .GenerateBoundary
                
                szBoundary = vbCrLf & "--" & .boundary & vbCrLf
                
                szMessage = szBoundary & _
                                mvarMailPlain.MimeHeader.Make & vbCrLf & _
                                mvarMailPlain.Content & _
                            szBoundary & _
                                mvarMailHTML.MimeHeader.Make & vbCrLf & _
                                mvarMailHTML.Content & _
                            vbCrLf & "--" & .boundary & "--" & vbCrLf
            End With
        End If
    End If
End If

Make = mvarMailHeader.Make & mh.Make & vbCrLf & szMessage

'les pièces jointes
If mvarMailBodies.Count Then
    For Each body In mvarMailBodies
        Make = Make & szBoundary & body.MimeHeader.Make & vbCrLf & body.Content
    Next
    Make = Make & vbCrLf & "--" & mh.ContentType.boundary & "--" & vbCrLf
End If
End Function

'ouvre un fichier EML szFileName et l'analyse en remplissant l'objet
Public Sub MailOpen(ByVal szFileName As String)
Dim buff As String, iFileNum As Integer

iFileNum = FreeFile
Open szFileName For Input As #iFileNum
    buff = Input(LOF(iFileNum), iFileNum)
Close #iFileNum

Parse buff

buff = vbNullString
End Sub

'enregistre le contenu de l'objet dans un fichier EML szFileName
Public Sub MailSave(ByVal szFileName As String)
Dim buff As String, iFileNum As Integer

iFileNum = FreeFile
Open szFileName For Output As #iFileNum
    Print #iFileNum, Make
Close #iFileNum
End Sub

'définit le texte sans mise en forme
Public Sub AddPlainText(ByVal szText As String, szCharset As String) ', Optional bAlternative As Boolean = False)
Dim mh As New CMIMEHeader

If szCharset = "us-ascii" Then
    With mh
        .ContentTransfertEncoding = "7bit"
        With .ContentType
            .charset = "us-ascii"
            .CTType = "text"
            .CTSubType = "plain"
        End With
        .ContentID = vbNullString
    End With
Else
    With mh
        .ContentTransfertEncoding = "quoted-printable"
        With .ContentType
            .charset = szCharset
            .CTType = "text"
            .CTSubType = "plain"
        End With
        .ContentID = vbNullString
        
        szText = .EncodeQPToString(szText)
    End With
End If
Set mvarMailPlain = New CMailBody
Set mvarMailPlain.MimeHeader = mh
mvarMailPlain.Content = szText

'If bAlternative Then
'    With mvarMIMEHeader.ContentType
'        .CTType = "multipart"
'        .CTSubType = "alternative"
'    End With
'End If
End Sub

'définit le texte HTML
Public Sub AddHTMLText(ByVal szHTML As String, szCharset As String) ', Optional bAlternative As Boolean = False)
Dim mh As New CMIMEHeader

If szCharset = "us-ascii" Then
    With mh
        .ContentTransfertEncoding = "7bit"
        With .ContentType
            .charset = "us-ascii"
            .CTType = "text"
            .CTSubType = "html"
        End With
        .ContentID = vbNullString
    End With
Else
    With mh
        .ContentTransfertEncoding = "quoted-printable"
        With .ContentType
            .charset = szCharset
            .CTType = "text"
            .CTSubType = "html"
        End With
        .ContentID = vbNullString
        
        szHTML = .EncodeQPToString(szHTML)
    End With
End If
Set mvarMailHTML = New CMailBody
Set mvarMailHTML.MimeHeader = mh
mvarMailHTML.Content = szHTML

'If bAlternative Then
'    With mvarMIMEHeader.ContentType
'        .CTType = "multipart"
'        .CTSubType = "alternative"
'    End With
'End If
End Sub

'définit une alternative de texte : Plain/HTML
'si le lecteur ne peut pas lire le HTML, il lira le Plain text
Public Sub AddAlternative(ByVal szPlain As String, szPlainCharset As String, ByVal szHTML As String, szHTMLCharset As String)
AddPlainText szPlain, szPlainCharset
AddHTMLText szHTML, szHTMLCharset
End Sub

'ajoute un pièce jointe au mail
Public Function AddAttachment(szFileName As String, Optional szMIMEType As String = vbNullString, Optional bEncMethod As Long = 0) As CMailBody
Dim data() As Byte, iFileNum As Integer
Dim body As CMailBody, mime() As String


iFileNum = FreeFile
Open szFileName For Binary As #iFileNum
    ReDim data(LOF(iFileNum) - 1)
    Get #iFileNum, , data
Close #iFileNum

Set body = New CMailBody

If Len(szMIMEType) = 0 Then
    szMIMEType = GetMIMEType(Mid$(szFileName, InStrRev(szFileName, ".")))
End If

mime = Split(szMIMEType, "/")

With body.MimeHeader.ContentType
    .charset = "us-ascii"
    .CTType = mime(0)
    .CTSubType = mime(1)
End With
With body.MimeHeader.ContentDisposition
    .CDType = "attachment"
    .FileName = Mid$(szFileName, InStrRev(szFileName, "\") + 1)
End With

If bEncMethod = 0 Then bEncMethod = best_encoding_method(ByVal VarPtr(data(0)), UBound(data) + 1)
If bEncMethod = 1 Then
    body.Content = body.MimeHeader.EncodeB64BinaryToString(data)
    body.MimeHeader.ContentTransfertEncoding = "base64"
Else
    body.Content = body.MimeHeader.EncodeQPBinaryToString(data)
    body.MimeHeader.ContentTransfertEncoding = "quoted-printable"
End If

mvarMailBodies.Add body, szFileName

Set AddAttachment = body
End Function


'ajoute une image dans un contenu HTML et renvoie le ContentID à inscrire dans src du tag IMG
Public Function AddImage(szFileName As String, Optional szContentID As String = vbNullString) As String
Dim body As CMailBody, szMIMEType As String

szMIMEType = GetMIMEType(Mid$(szFileName, InStrRev(szFileName, ".")))
If Mid$(szMIMEType, 1, 6) = "image/" Then
    Set body = AddAttachment(szFileName, szMIMEType)
End If

If Not body Is Nothing Then
    With body.MimeHeader
        With .ContentDisposition
            .FileName = vbNullString
            .CDType = vbNullString
        End With
        .ContentType.CTName = Mid$(szFileName, InStrRev(szFileName, "\") + 1)
        If Len(szContentID) Then
            .ContentID = szContentID
        Else
            .GenerateContentID
        End If
        AddImage = "cid:" & .ContentID
    End With
End If
End Function

'supprime le texte sans formattage
Public Sub RemovePlain()
Set mvarMailPlain = Nothing
End Sub

'supprime le texte HTML
Public Sub RemoveHTML()
Set mvarMailHTML = Nothing
End Sub

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

Private Sub Class_Initialize()
    Set mvarMailHTML = Nothing
    Set mvarMailPlain = Nothing

    Set mvarMailHeader = New CMailHeader
    Set mvarMIMEHeader = New CMIMEHeader
    Set mvarMailBodies = New MailBodies
    
    mvarMIMEHeader.ContentTransfertEncoding = "7bit"
End Sub

Private Sub Class_Terminate()
    Set mvarMailHeader = Nothing
    Set mvarMIMEHeader = Nothing
    Set mvarMailBodies = Nothing
End Sub

