VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CMIMEHeader"
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"
'programmed by ShareVB
'gestion d'une entête MIME et des méthodes de codage définies par MIME

Option Explicit
Option Compare Text

'BASE64 : codage des données binaires
'demande la taille des données encodées
Private Declare Function base_64_encode_size Lib "MIMECode.dll" Alias "_base_64_encode_size@4" (ByVal cb As Long) As Long

'encode les données
Private Declare Function base_64_encode_from_string Lib "MIMECode.dll" Alias "_base_64_encode@12" (ByVal dest As String, ByVal src As String, ByVal srclen As Long) As Long
Private Declare Function base_64_encode_from_bin Lib "MIMECode.dll" Alias "_base_64_encode@12" (ByVal dest As String, ByVal src As Long, ByVal srclen As Long) As Long

'décode les données
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 Declare Function base_64_decode_to_bin Lib "MIMECode.dll" Alias "_base_64_decode@8" (ByVal dest As Long, ByVal src As String) As Long

'QUOTED-PRINTABLE : codage des textes
'demande la taille des données encodées
Private Declare Function quoted_printable_encoded_size_from_string Lib "MIMECode.dll" Alias "_quoted_printable_encoded_size@4" (ByVal src As String) As Long
'encode
Private Declare Function quoted_printable_encode_from_string Lib "MIMECode.dll" Alias "_quoted_printable_encode@8" (ByVal dest As String, ByVal src As String) As Long

'demande la taille des données encodées
Private Declare Function quoted_printable_encoded_size_from_bin Lib "MIMECode.dll" Alias "_quoted_printable_encoded_size@4" (ByVal src As Long) As Long
'encode
Private Declare Function quoted_printable_encode_from_bin Lib "MIMECode.dll" Alias "_quoted_printable_encode@8" (ByVal dest As String, ByVal src As Long) As Long

'decode
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 quoted_printable_decode_to_bin Lib "MIMECode.dll" Alias "_quoted_printable_decode@8" (ByVal dest As Long, ByVal src As String) As Long

'gestion des images : sert à l'extraction en StdPicture
Private Const GMEM_MOVEABLE As Long = &H2
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Long) As Long
Private Declare Function OleLoadPicture Lib "oleaut32.dll" (ByVal lpstream As Long, ByVal lSize As Long, ByVal fRunmode As Long, ByVal riid As Long, ByRef lplpvObj As StdPicture) As Long
Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long

'nom de l'ordi : sert pour content ID
Private Declare Function api_GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, ByRef nSize As Long) As Long

Private Const mVersion As String = "1.0"
Private mvarContentType As CContentType 'copie locale
Private mvarContentDisposition As CContentDisposition 'copie locale
Private mvarContentDescription As CContentDescription 'copie locale
Private mvarContentTransfertEncoding As String 'copie locale
Private mvarContentID As String 'copie locale

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

Public Property Let ContentTransfertEncoding(ByVal vData As String)
Attribute ContentTransfertEncoding.VB_HelpID = 129
'utilisé lors de l'affectation d'une valeur à la propriété, du coté gauche de l'affectation.
'Syntax: X.ContentTransfertEncoding = 5
    mvarContentTransfertEncoding = vData
End Property

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

Public Property Let ContentID(ByVal vData As String)
    mvarContentID = vData
End Property
Public Property Get ContentID() As String
'utilisé lors de la lecture de la valeur de la propriété, du coté droit de l'instruction.
'Syntax: Debug.Print X.ContentID
    ContentID = mvarContentID
End Property

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

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

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

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

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

Private Function GetComputerName() As String
    Dim nSize As Long
    
    nSize = 256
    GetComputerName = Space(256)
    api_GetComputerName GetComputerName, nSize
    GetComputerName = Mid$(GetComputerName, 1, nSize)
End Function


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

Private Function Unfolding(szHeaders As String) As String
Unfolding = Replace(szHeaders, vbCrLf & vbTab, " ")
Unfolding = Replace(Unfolding, vbCrLf & " ", " ")
End Function

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

'génère un Content-ID
Public Sub GenerateContentID()
Randomize Timer
mvarContentID = Right$("00000000" & Hex$(CLng(&H7FFFFFF0 * Rnd)), 8) & "$" & _
                Right$("00000000" & Hex$(CLng(&H7FFFFFF0 * Rnd)), 8) & "$" & _
                Right$("00000000" & Hex$(CLng(&H7FFFFFF0 * Rnd)), 8) & "$" & _
                Right$("00000000" & Hex$(CLng(&H7FFFFFF0 * Rnd)), 8) & "@" & GetComputerName
End Sub

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 "Content-Transfer-Encoding"
                mvarContentTransfertEncoding = szValue
            Case "Content-Type"
                mvarContentType.Parse szValue
            Case "Content-Disposition"
                mvarContentDisposition.Parse szValue
            Case "Content-Description"
                mvarContentDescription.Parse szValue
            Case "Content-ID"
                mvarContentID = szValue
        End Select
    End If
Next
End Sub

Public Function Make() As String
    Dim szDispo As String, szDescr As String
    
    szDispo = mvarContentDisposition.Make
    szDescr = mvarContentDescription.Make
    Make = "MIME-Version: 1.0" & vbCrLf & _
        Folding(mvarContentType.Make) & vbCrLf & _
        Folding("Content-Transfer-Encoding: " & _
        mvarContentTransfertEncoding) & vbCrLf
    
    If Len(szDispo) Then Make = Make & Folding(szDispo) & vbCrLf
    If Len(szDescr) Then Make = Make & Folding(szDescr) & vbCrLf
    If Len(mvarContentID) Then Make = Make & Folding("Content-ID: " & mvarContentID & "") & vbCrLf
End Function

Public Function DecodeB64ToString(sz As String) As String
Dim l As Long

DecodeB64ToString = Space(Len(sz) + 1)

l = base_64_decode_to_string(DecodeB64ToString, sz)

DecodeB64ToString = Mid$(DecodeB64ToString, 1, l)

If InStr(DecodeB64ToString, vbNullChar) Then DecodeB64ToString = Mid$(DecodeB64ToString, 1, InStr(DecodeB64ToString, vbNullChar) - 1)
End Function

Public Function DecodeB64ToBinary(sz As String) As Byte()
Dim l As Long
Dim tmp() As Byte

ReDim tmp(Len(sz))

l = base_64_decode_to_bin(ByVal VarPtr(tmp(0)), sz)

ReDim Preserve tmp(l - 1)

DecodeB64ToBinary = tmp
End Function

Public Function DecodeQPToString(sz As String) As String
Dim l As Long

DecodeQPToString = Space(Len(sz) + 1)

l = quoted_printable_decode_to_string(DecodeQPToString, sz)

DecodeQPToString = Mid$(DecodeQPToString, 1, l)

If InStr(DecodeQPToString, vbNullChar) Then DecodeQPToString = Mid$(DecodeQPToString, 1, InStr(DecodeQPToString, vbNullChar) - 1)
End Function

Public Function DecodeQPToBinary(sz As String) As Byte()
Dim l As Long
Dim tmp() As Byte

ReDim tmp(Len(sz))

l = quoted_printable_decode_to_bin(ByVal VarPtr(tmp(0)), sz)

ReDim Preserve tmp(l - 1)
DecodeQPToBinary = tmp
End Function


Public Function DecodeB64ToPicture(sz As String) As IPicture
Dim hMem As Long, ptr As Long, l As Long, pStream As Long
Dim IID_IPicture(3) As Long, ret As Long

l = Len(sz)

'alloue de la mémoire pour le données de l'image
hMem = GlobalAlloc(GMEM_MOVEABLE, l)

If hMem = 0 Then Exit Function

'demande un pointeur vers la zone allouée
ptr = GlobalLock(hMem)

If ptr = 0 Then GlobalFree hMem: Exit Function

'copie les données décodées dans cette zone
l = base_64_decode_to_bin(ByVal ptr, sz)

GlobalUnlock hMem

'crée un flux à partir de la zone : le flux libérera la zone à sa libération
If CreateStreamOnHGlobal(hMem, 1&, pStream) <> 0 Then GlobalFree hMem: Exit Function

'IID_IPicture = {7BF80980-BF32-101A-8BBB-00AA00300CAB}
IID_IPicture(0) = &H7BF80980
IID_IPicture(1) = &H101ABF32
IID_IPicture(2) = &HAA00BB8B
IID_IPicture(3) = &HAB0C3000

'crée un IPicture à partir du flux : le flux sera libéré par le IPicture
ret = OleLoadPicture(pStream, l, 0&, ByVal VarPtr(IID_IPicture(0)), DecodeB64ToPicture)
End Function

Public Function DecodeQPToPicture(sz As String) As IPicture
Dim hMem As Long, ptr As Long, l As Long, pStream As Long
Dim IID_IPicture(3) As Long

l = Len(sz)

hMem = GlobalAlloc(GMEM_MOVEABLE, l)

If hMem Then Exit Function

ptr = GlobalLock(hMem)

If ptr = 0 Then GlobalFree hMem: Exit Function

quoted_printable_decode_to_bin ByVal ptr, sz

GlobalUnlock hMem

If CreateStreamOnHGlobal(hMem, 1&, pStream) <> 0 Then GlobalFree hMem: Exit Function

'IID_IPicture = {7BF80980-BF32-101A-8BBB-00AA00300CAB}

IID_IPicture(0) = &H7BF80980
IID_IPicture(1) = &H101ABF32
IID_IPicture(2) = &HAA00BB8B
IID_IPicture(3) = &HAB0C3000

OleLoadPicture pStream, l, 0&, ByVal VarPtr(IID_IPicture(0)), DecodeQPToPicture
End Function

Public Function EncodeQPBinaryToString(data() As Byte) As String
Dim l As Long

EncodeQPBinaryToString = Space(quoted_printable_encoded_size_from_bin(ByVal VarPtr(data(0))))
l = quoted_printable_encode_from_bin(EncodeQPBinaryToString, ByVal VarPtr(data(0)))
EncodeQPBinaryToString = Mid$(EncodeQPBinaryToString, 1, l)
End Function

Public Function EncodeQPToString(sz As String) As String
Dim l As Long

EncodeQPToString = Space(quoted_printable_encoded_size_from_string(sz))
l = quoted_printable_encode_from_string(EncodeQPToString, sz)
EncodeQPToString = Mid$(EncodeQPToString, 1, l)
End Function

Public Function EncodeB64BinaryToString(data() As Byte) As String
Dim l As Long
EncodeB64BinaryToString = Space(base_64_encode_size(UBound(data) + 1) + 1)

l = base_64_encode_from_bin(EncodeB64BinaryToString, ByVal VarPtr(data(0)), UBound(data) + 1)
EncodeB64BinaryToString = Mid$(EncodeB64BinaryToString, 1, l)
End Function

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

Private Sub Class_Initialize()
Set mvarContentType = New CContentType
Set mvarContentDisposition = New CContentDisposition
Set mvarContentDescription = New CContentDescription
End Sub

Private Sub Class_Terminate()
Set mvarContentDescription = Nothing
Set mvarContentDisposition = Nothing
Set mvarContentType = Nothing
End Sub

