I. Présentation

Cet exemple, écrit en VBScript, illustre une technique d'envoi de mails par injection des données du message dans la base de DreamMail, un client mail d'origine chinoise. Il tire parti des informations contenues dans une documentation précédemment publiée sur mon site. Ce script permet la création d'un message de type texte accompagné éventuellement d'un fichier au format zip, rtf, doc, pdf ou txt. Ce message est placé dans la boite d'envoi et sera traité par DreamMail de trois façons différentes :
- soit par envoi manuel de l'utilisateur.
- soit automatiquement si cette fonction est déjà activée dans le logiciel.
- soit à une date et heure déterminée si le champ mWaitToSendTime est correctement renseigné dans le script.

Par la même occasion, ce script fournit un exemple de compression de stream au moyen de la bibliothèque zlib1 très largement utilisée par les programmeurs.

Il s'agit d'une preuve de concept et non d'un script véritablement utilisable faute d'interface graphique digne de ce nom. Son adaptation sous la forme d'une macro VBA ne présente aucune difficulté majeure.

II. Le script VBS

 
Sélectionnez

'*********************************************************************************************************
' SendDMail par omen999 - (omen999.developpez.com)
' envoi d'un mail par injection directe dans la base de données du client DreamMail
' v 2.2 (support composant Buffer- XStandard et zlib) DM v 4.6.5.5
' PoC (pas de gestion sérieuse des erreurs, pas d'interface gui)
'
' l'objet de ce script est d'envoyer un mail en insérant les données directement dans les fichiers de DM
' le mail est en mode texte mais avec possibilité de joindre une pièce au format zip, rtf, doc, pdf ou txt
' DM procèdera ensuite à son envoi de façon autonome et asynchrone
' deux étapes sont nécessaires :
'  création du fichier msg au format eml
'  insertion d'un nouvel enregistrement dans le fichier DmData.dao cible en utilisant un objet DAO
' cette version 2.2 vise à créer un message indiscernable de ceux définis par le logiciel
' pour des raisons de performances, les opérations de hashage md5 et d'encodage base64 sont confiées
' au composant Buffer (www.xstandard.com/en/documentation/xbuffer)
' la compression zlib à la bibliothèque ... zlib (www.zlib.net) et 
' au composant DynamicWrapperX (omen999.developpez.com/tutoriels/vbs/DynamicWrapperX)
'*********************************************************************************************************
Option Explicit
'constantes DAO
'RecordsetTypeEnum
Const _
dbOpenTable = 1, _
dbOpenDynaset = 2, _
dbOpenSnapshot = 4, _
dbOpenForwardOnly = 8, _
dbOpenDynamic = 16
'RecordsetOptionEnum
Const _
dbAppendOnly = 8, _
dbConsistent = 32, _
dbDenyRead = 2, _
dbDenyWrite = 1, _
dbExecDirect = 2048, _
dbFailOnError = 128, _
dbForwardOnly = 256, _
dbInconsistent = 16, _
dbRunAsync = 1024, _
dbSeeChanges = 512, _
dbSQLPassThrough = 64
'RecordsetLockEditsEnum
Const _
dbPessimistic = 2, _ 
dbOptimistic = 3, _
dbOptimisticValue = 1, _
dbReadOnly = 4, _
dbOptimisticBatch = 5
'constantes zlib
Const _
Z_OK = 0, _
Z_DATA_ERROR = -3, _
Z_MEM_ERROR = -4, _
Z_BUF_ERROR = -5

Const _
Z_NO_COMPRESSION = 0, _
Z_BEST_SPEED = 1, _
Z_BEST_COMPRESSION = 9, _
Z_DEFAULT_COMPRESSION = -1

'définition tableaux
Dim aDay,aMonth,aMIME,aTMIME
aDay=Array("Sun","Mon","Tue","Wed","Thu","Fri","Sat")
aMonth=Array("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec")
aMIME=Array("application/zip","application/rtf","application/msword","application/pdf","text/plain")

'définition variables
Dim oFso,oFile,oHeaderFile,oBuffer,oWrap
Dim oDmJet,oDmDb,oRecAc,oRecEm 'variables DAO
Dim dmBaseName,sFolderBase,sCountName,sFolder,sEmlFile,sFullFile,dDate,sTypeMime,sReply
Dim sDest,sCC,sBCC,sSujet,sExtAtName,sFullAtName,sAtName,sBody,bAttExist,sBoundaryStr,sHeader
Dim smTo,smToShowName,smToShowAddr,smCc,smCcShowName,smCcShowAddr,smBcc,smZipText,uLenZipBuffer,smZipHtml,sRep
Set oDmJet=CreateObject("DAO.DBEngine.36")
Set oFso = CreateObject("Scripting.FileSystemObject")
Set oBuffer=CreateObject("XStandard.Buffer")
Set oWrap=CreateObject("DynamicWrapperX")
'dynamicwrapperx gère indifféremment les conventions stdcall ou cdecl
oWrap.Register "zlib1.dll","compress2","i=pUsul","r=l"
oWrap.Register "zlib1.dll","compressBound","i=l","r=l"

Sub WriteMailHeader(sList, sField)
'génère le header et les champs destinataires à partir de sList  chaque item est séparé par une virgule
'sField prend les valeurs "To :" "CC :" ou "BCC :"
Dim aMail, iC, sName
  aMail=Split(sList,",")
  oFile.Write sField
  For iC=0 to UBound(aMail)
    sName = Left(aMail(iC),InStr(aMail(iC),"@")-1)
    oFile.Write Chr(34) & sName & Chr(34) & "<" & aMail(iC) & ">"
    If iC < UBound(aMail) Then oFile.Write ", "
      Select Case sField
      Case "To: " smTo = smTo & Chr(34) & sName & Chr(34) & "<" & aMail(iC) & ">"
                  smToShowName = smToShowName & sName
                  smToShowAddr = smToShowAddr & aMail(iC)
                  If iC < UBound(aMail) Then
                    smTo = smTo & ","
                    smToShowName = smToShowName & ","
                    smToShowAddr = smToShowAddr & ","
                  End If
      Case "CC: " smCc = smCc & Chr(34) & sName & Chr(34) & "<" & aMail(iC) & ">"
                  smCcShowName = smCcShowName & sName
                  smCcShowAddr = smCcShowAddr & aMail(iC)
                  If iC < UBound(aMail) Then
                    smCc = smCc & ","
                    smCcShowName = smCcShowName & ","
                    smCcShowAddr = smCcShowAddr & ","
                  End If
     Case "BCC: " smBcc = smBcc & Chr(34) & sName & Chr(34) & "<" & aMail(iC) & ">"
                  If iC < UBound(aMail) Then smBcc = smBcc & ","
      End Select     
  Next
  oFile.WriteLine	  
End Sub

'ouverture de la BD en mode partagé et lecture/écriture
dmBaseName=InputBox("Entrez le nom complet de la base de données (DmData.dao) :")
Set oDmDb=oDmJet.OpenDatabase(dmBaseName,False,False,"MS Access;pwd=@i_10ve_U&^@^Rapid_?")

'récupération des données du compte d'envoi
Do
  sCountName=InputBox("Entrez le nom du compte à partir duquel le mail sera créé :")
  If sCountName="" Then
    oDmDb.Close
    WScript.Quit	
  End If
  Set oRecAc=oDmDb.OpenRecordset("SELECT * FROM Account WHERE aAccountDisplayName=" & Chr(34) & sCountName & Chr(34),dbOpenSnapshot)
Loop Until oRecAc.RecordCount > 0

'entrée des données du mail par l'utilisateur
sDest=InputBox("Adresse mail du ou des destinataires séparés par une virgule :")
sCC=InputBox("Adresse mail du ou des destinataires en copie séparés par une virgule :")
sBCC=InputBox("Adresse mail du ou des destinataires en copie cachée séparés par une virgule :")
sSujet=InputBox("Sujet du message")
sBody=InputBox("Texte du message")
sFullAtName=InputBox("Nom complet du fichier à joindre au message :")
bAttExist=False
If oFso.FileExists(sFullAtName) Then
  sExtAtName=oFso.GetExtensionName(sFullAtName)	
  If sExtAtName="txt" Then sExtAtName="text"
    aTMIME=Filter(aMIME,sExtAtName)
    If IsArray(aTMIME) Then 
      sTypeMime=aTMIME(0)
      sAtName=oFso.GetFileName(sFullAtName)
      bAttExist=True
    Else
      MsgBox "Type MIME inconnu"
      oRecAc.Close
      oDmDb.Close
      WScript.Quit	
  End If
End If

'création du fichier eml
dDate=Now
sFolder=Year(dDate) & Right("0" & Month(dDate),2)
'petite précaution...
sFolderBase=oFso.GetParentFolderName(dmBaseName)
If not oFso.FolderExists(sFolderBase & "\Data\" & oRecAc.Fields("aEmailAddress") & "\" & sFolder) Then
  oFso.CreateFolder sFolderBase & "\Data\" & oRecAc.Fields("aEmailAddress") & "\" & sFolder
End If
'même s'il existe un hack sous vbs pour récupérer les millisecondes, j'ai préféré faire un random pour générer les 3 derniers caractères ;)
Randomize
sEmlFile=Right("0" & Day(dDate),2) & Right("0" & Hour(dDate),2) & Right("0" & Minute(dDate),2) & Right("0" & Second(dDate),2) & Left(Int(Rnd*100000),3)
sFullFile = sFolderBase & "\Data\" & oRecAc.Fields("aEmailAddress") & "\" & sFolder & "\" & sEmlFile
Set oFile=oFso.CreateTextFile(sFullFile & ".eml", True)
If IsNull(oRecAc.Fields("aReplyAddress")) Then 
  sReply=oRecAc.Fields("aEmailAddress")
Else
  sReply=oRecAc.Fields("aReplyAddress")
End If
oFile.WriteLine "Reply-To: " & sReply
oFile.WriteLine "From: " & Chr(34) & oRecAc.Fields("aDisplayName") & Chr(34) & "<" & oRecAc.Fields("aEmailAddress") & ">"
WriteMailHeader sDest,"To: "
If sCC <>"" Then WriteMailHeader sCC,"CC: "
If sBCC <>"" Then WriteMailHeader sBCC,"BCC: "
oFile.WriteLine "Subject: " & sSujet
oFile.WriteLine "Date: " & aDay(Weekday(dDate)-1) & ", " & Day(dDate) & " " & aMonth(Month(dDate)-1) & " " & Year(dDate) & " " & _
                FormatDateTime(dDate,3) & " +0100" 'timezone france ex : Wed, 17 Mar 2010 17:57:45 +0100
oFile.WriteLine "Message-Id: DreamMailOutBox"
oFile.WriteLine "MIME-Version: 1.0"
'si pièce jointe création d'une boundary string
If bAttExist Then 
  sBoundaryStr="----=_NextPart_" & Right(Year(dDate),2) & Right("0" & Month(dDate),2) & Left(sEmlFile,9) & Int(Rnd * 10000000000) & "_000"
  oFile.WriteLine "Content-Type: multipart/mixed; " 'un espace en fin de ligne
  oFile.WriteLine vbTab & "boundary=""" & sBoundaryStr & """"
Else
  oFile.WriteLine "Content-Type: text/plain;"
  oFile.WriteLine vbTab & "charset=""ISO-8859-1"""
End If
oFile.WriteLine "X-Priority: 3"
oFile.WriteLine "X-Mailer: DreamMail 4.6.5.5" & vbCrLf
If bAttExist Then
  oFile.WriteLine "--" & sBoundaryStr
  oFile.WriteLine "Content-Type: text/plain; " 'un espace en fin de ligne
  oFile.WriteLine vbTab & "charset=""ISO-8859-1"""
  oFile.WriteLine "Content-Transfer-Encoding: 8bit" & vbCrLf
End If

'pour le hash md5 du header
Set oHeaderFile=oFso.OpenTextFile(sFullFile & ".eml",1)
sHeader=oHeaderFile.ReadAll
oHeaderFile.Close

'fin du header écriture du corps du message
oFile.WriteLine sBody & vbCrLf

'écriture de la pièce attachée
If bAttExist Then
  oFile.WriteLine "--" & sBoundaryStr
  oFile.WriteLine "Content-Type: " & sTypeMime & "; " 'espace en fin de ligne
  oFile.WriteLine vbTab & "name=""" & sAtName & """"
  oFile.WriteLine "Content-Transfer-Encoding: base64"
  oFile.WriteLine "Content-Disposition: attachment;"
  oFile.WriteLine vbTab & "filename=""" & sAtName & """" & vbCrLf
  oBuffer.Load sFullAtName
  oFile.WriteLine oBuffer.Base64String & vbCrLf
  oBuffer.Reset
  oFile.WriteLine "--" & sBoundaryStr & "--" & vbCrLf
End If
oFile.Close

'pour terminer création d'un nouvel enregistrement dans la BD de DreamMail
Set oRecEm=oDmDb.OpenRecordSet("Email",dbOpenTable,0,dbOptimistic)
With oRecEm
  .AddNew
  .Fields("mAccountID")=oRecAc.Fields("Id")              'ID du compte d'où partira le message
  .Fields("mMailBoxID")=2                                'boite non-envoyés
  .Fields("mDisplayColor")=0                             'police couleur noire
  .Fields("mSize")=oFso.GetFile(sFullFile & ".eml").Size 'taille du msg 
  .Fields("mPriority")=2                                 'normale 0:haute 4:basse
  .Fields("mIsRead")=1                                   '0=non-lu 1=lu
  .Fields("mReplyMailID")=0                              'défaut
  .Fields("mFwMailID")=0                                 'défaut
  .Fields("mIsFlag")=0                                   'défaut
  .Fields("mMailType")=0                                 'défaut
  .Fields("mIsAttrExists")=0                             'défaut
  .Fields("mIsAskReadReply")=0                           'demande AR 0=non 1=oui
  If .Fields("mIsAskReadReply")=0 Then 
    .Fields("mAskReadReplyAddress")=""                   'champ vierge si pas d'AR
  Else
    .Fields("mAskReadReplyAddress")=sReply               'adresse de retour d'AR 
  End If                                                 'j'ai choisi la même que l'adresse de réponse mais ce n'est pas obligatoire
  .Fields("mMessageID")="DreamMailOutBox"                'valeur générique pour les msgs en attente
  .Fields("mReferences")=""                              'champ facultatif contenu libre
                                                         'date du message
  .Fields("mDate")=Year(dDate) & "-" & Right("0" & Month(dDate),2) & "-" & Right("0" & Day(dDate),2) & ", " & FormatDateTime(dDate,3)
                                                         'date de création effective dans la BD
  .Fields("mCreateDate")=Year(dDate) & "-" & Right("0" & Month(dDate),2) & "-" & Right("0" & Day(dDate),2) & ", " & Time 
  .Fields("mCharset")="ISO-8859-15"                      'code charset (latin 9)
  .Fields("mSubject")=sSujet                             'sujet
  .Fields("mReplyTo")=sReply                             'adresse utilisée pour la réponse
                                                         'champ standard identifant l'expéditeur notez l'espace
                                                         '(décomposé dans les deux champs suivants)
  .Fields("mFrom")="""" & oRecAc.Fields("aDisplayName") & """ <" & oRecAc.Fields("aEmailAddress") & ">" 
  .Fields("mFromShowName")=oRecAc.Fields("aDisplayName") 'nom affiché de l'expéditeur
  .Fields("mFromShowAddr")=oRecAc.Fields("aEmailAddress")'adresse mail du compte expéditeur
  .Fields("mTo")=smTo                                    'champ standard liste des destinataires
  .Fields("mToShowName")=smToShowName                    'liste des noms destinataires
  .Fields("mToShowAddr")=smToShowAddr                    'liste des adresses destinataires
  If sCC <> "" Then
    .Fields("mCc")=smCc                                  'champ standard liste des dests en copie
    .Fields("mCcShowName")=smCcShowName                  'liste des noms dests en copie
    .Fields("mCcShowAddr")=smCcShowAddr                  'liste des adresses dests en copie
  End If
  oBuffer.Write sHeader                                  'chargement du header dans l'objet Buffer
  .Fields("mHeaderMD5")=oBuffer.MD5                      'valeur de hash de l'en-tête msg
  oBuffer.Reset
  If sBCC <> "" Then .Fields("mBcc")=smBcc               'champ standard liste des dests en copie cachée
  .Fields("mWaitToSendTime")=""                          'date de l'envoi différé [IMPORTANT] la date doit avoir le format "AAAA-MM-JJ, hh:mm:ss"
  .Fields("mDisplayDecodeType")=0                        'décodage auto
  If bAttExist Then .Fields("mAttrList")=sAtName & "|" & oFso.GetFile(sFullAtName).Size 'liste des noms de fichiers joints avec leur taille en octets
  .Fields("mDetail")=""                                  'commentaire associé au msg (facultatif)
  'le champ mZipText est un blob qui contient un stream compressé zlib (mode best_speed) du corps du message
  'ce champ est utilisé par le volet prévisualisation pour éviter de ralentir l'affichage
  If Right(sBody,2) <> vbCrLf Then                       'le texte doit se terminer par un cr/lf
    sBody = sBody & vbCrLf
  End If
  uLenZipBuffer=oWrap.compressBound(Len(sBody))          'taille à prévoir du buffer en sortie
  smZipText=oWrap.Space(Round(uLenZipBuffer/2),"")       'uniquement valable pour les messages charset latin
  sRep = ""
  Select Case oWrap.compress2(smZipText, uLenZipBuffer, sBody, Len(sBody), Z_BEST_SPEED)
  Case Z_MEM_ERROR
  						sRep = "Mémoire insuffisante"
  Case Z_BUF_ERROR
  						sRep = "Taille insuffisante du buffer"
  Case Z_DATA_ERROR
  						sRep = "Erreur pendant l'opération de compression"
  End Select
  If sRep <> "" Then
    MsgBox sRep, vbExclamation, "Erreur Compression ZLib"
    oRecEm.Close
    oRecAc.Close
    oDmDb.Close     
    WScript.Quit
  End If
  .Fields("mZipText").AppendChunk LeftB(smZipText,uLenZipBuffer) 'tronque la chaine à sa longueur utile 
  'même quand le msg est en mode texte, DM complète le champ mZipHtml avec un stream zlib correspondant à une chaine vide...
  'soit les 8 octets suivants : x78 x01 x03 x00 x00 x00 x00 x01
  smZipHtml=oWrap.Space(4,"") '4 unicode = 8 octets
  'on place deux valeurs 32bits en tenant compte du format little endian...
  oWrap.NumPut &h30178,smZipHtml,0,"u"
  oWrap.NumPut &h1000000,smZipHtml,0 + 4,"u"
  .Fields("mZipHtml").AppendChunk smZipHtml              'contenu zippé du corps msg en html (utilisé par le volet prévisualisation)
                                                         'nom complet du fichier eml
  .Fields("mSourceSaveFile")="${DBPATH}\Data\" & oRecAc.Fields("aEmailAddress") & "\" & sFolder & "\" & sEmlFile & ".eml" 
  .Fields("mIsEditMail")=1                               'signale que le message a été édité (DM v 4.6.5.5)
  .Update                                                'écriture du msg dans la BD
  .Close
End With
oRecAc.Close
oDmDb.Close

III. Liens