VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CMailBody"
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 = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"MailSubBodies"
'programmed by ShareVB
'gestion d'une partie d'un mail

Option Explicit
Option Compare Text

Private mvarContent As String 'copie locale
Private mvarMIMEHeader As CMIMEHeader 'copie locale

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 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

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

Public Property Set MimeHeader(ByVal vData As CMIMEHeader)
Attribute MimeHeader.VB_HelpID = 167
'utilisé lors de l'affectation d'un objet à la propriété, du coté gauche de l'instruction Set.
'Syntax: Set x.MIMEHeader = Form1
    Set mvarMIMEHeader = vData
End Property
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 Let Content(ByVal vData As String)
Attribute Content.VB_HelpID = 165
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.Content = 5
    mvarContent = vData
End Property
Public Property Get Content() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.Content
    Content = mvarContent
End Property

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

'analyse
Public Sub Parse(szMail As String)
Dim szHeaders As String, szBody As String
Dim pos As Long, body 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"

mvarMIMEHeader.Parse szHeaders

szBody = Mid$(szMail, pos + 4)

mvarContent = szBody
End Sub

'extrait le texte (si la partie en est) de la partie
Public Function ExtractText(lpText As String) As Boolean
With mvarMIMEHeader
    If .ContentType.CTType = "text" Then
        Select Case .ContentTransfertEncoding
            Case "base64"
                lpText = .DecodeB64ToString(mvarContent)
            Case "quoted-printable"
                lpText = .DecodeQPToString(mvarContent)
            Case Else
                lpText = mvarContent
        End Select
        ExtractText = True
    Else
        ExtractText = False
    End If
End With
End Function

'extrait une image (si la partie en est) de la partie
Public Function ExtractImage() As StdPicture
With mvarMIMEHeader
    If .ContentType.CTType = "image" Then
        Select Case .ContentTransfertEncoding
            Case "base64"
                Set ExtractImage = .DecodeB64ToPicture(mvarContent)
            Case "quoted-printable"
                Set ExtractImage = .DecodeQPToPicture(mvarContent)
        End Select
    End If
End With
End Function

'extrait les données brutes de la partie
Public Function ExtractBinary(lpBuff() As Byte) As Boolean
With mvarMIMEHeader
    Select Case .ContentTransfertEncoding
        Case "base64"
            lpBuff = .DecodeB64ToBinary(mvarContent)
        Case "quoted-printable"
            lpBuff = .DecodeQPToBinary(mvarContent)
        Case Else
            lpBuff = mvarContent
    End Select
    ExtractBinary = True
End With
End Function

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

Private Sub Class_Initialize()
Set mvarMIMEHeader = New CMIMEHeader
End Sub

Private Sub Class_Terminate()
Set mvarMIMEHeader = Nothing
End Sub
