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 :
' 1° création du fichier msg au format eml
' 2° 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 où 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