- Code : Tout sélectionner
Public Class SmartMail
Private rcpTo As String
Private rcpCC As String
Private rcpBCC As String
Private s As NotesSession
Private doc As NotesDocument
Private body As NotesMIMEEntity
Private mimeType List As String
Private isMimeInitialized As Boolean
Private partCount As Integer
Private mailbox As NotesDatabase
'Constructeur
Sub new(theSession As NotesSession)
Set s=theSession
If s Is Nothing Then Set s=New NotesSession
isMimeInitialized=False
partCount=0
s.ConvertMIME = False
Dim thisDb As NotesDatabase
Set thisDb=s.CurrentDatabase
Dim thisServer As String
thisServer=thisDb.Server
Set mailbox=s.GetDatabase(thisServer,"mail.box")
If mailbox Is Nothing Then Set mailbox=thisDb
Set doc=mailbox.CreateDocument()
Call doc.ReplaceItemValue("Form", "Memo")
Set body = doc.CreateMIMEEntity
End Sub
'Creer un header
Sub setHeaderVal(hName As String, hVal As String)
Dim header As NotesMIMEHeader
Set header=body.GetNthHeader(hName)
If header Is Nothing Then Set header=body.CreateHeader(hName)
Call header.SetHeaderVal(hVal)
End Sub
'Set le champ To
Sub setTo(toStr As String)
rcpTo=toStr
Call setHeaderVal("To", toStr)
End Sub
'Set le champ CC
Sub setCC(toStr As String)
rcpCC=toStr
Call setHeaderVal("CC", toStr)
End Sub
'Set le champ BCC
Sub setBCC(toStr As String)
rcpBCC=toStr
Call setHeaderVal("BCC", toStr)
End Sub
'Set le champ Principal
Sub setPrincipal(toStr As String)
rcpBCC=toStr
Call setHeaderVal("Principal", toStr)
End Sub
'Set le champ FromTo
Sub setFromTo(toStr As String)
rcpBCC=toStr
Call setHeaderVal("FromTo", toStr)
End Sub
'Set le champ Sujet
Sub setSubject(subject As String)
Call setHeaderVal("Subject", subject)
End Sub
'Ajoute un objet fichier dans le corp du mail à partir de son chemin
Function addFileObject(filepath As String) As String
addFileObject=""
Dim theStream As NotesStream
Set theStream=s.CreateStream()
If theStream.Open(filepath) Then
Dim fileSuffix As String
fileSuffix=Lcase(Strrightback(filepath,"."))
Dim filename As String
If Instr(filepath,"/")>0 Then
filename=Strrightback(filepath,"/")
Elseif Instr(filepath,"\")>0 Then
filename=Strrightback(filepath,"\")
Else
filename=filepath
End If
If isKnownMimeType(fileSuffix) Then
addFileObject=addStreamObject(theStream, mimeType(fileSuffix),{inline; filename="} & filename & {"})
Else
Error 9999, {Type of file object "} & filepath & {" is not supported by method SmartMail.addFileObject(). Use SmartMail.addStreamObject() instead.}
End If
Else
Error 53, {File "} & filepath & {" not found in method SmartMail.addFileObject()}
End If
End Function
'Ajoute un objet stream dans le corp du mail à partir de son chemin
Function addStreamObject(theStream As NotesStream, theMimeType As String, disposition As String) As String
addStreamObject=""
Call setHeaderVal("Content-Type", "multipart/related")
Dim part As NotesMimeEntity
Set part=body.CreateChildEntity()
Dim idHeader As NotesMimeHeader
Set idHeader=part.CreateHeader("Content-ID")
Dim cid As String
cid=doc.UniversalID+"."+Cstr(partCount)
Call idHeader.SetHeaderVal("<"+cid+">")
Dim dispositionHeader As NotesMimeHeader
Set dispositionHeader=part.CreateHeader("Content-Disposition")
Call dispositionHeader.SetHeaderValAndParams(disposition)
Call part.SetContentFromBytes(theStream, theMimeType, ENC_IDENTITY_BINARY)
partCount=partCount+1
addStreamObject="cid:"+cid
End Function
'Insere un contenu HTML dans le body
Sub setHtmlBody(code As String)
Dim theStream As NotesStream
Set theStream=s.CreateStream()
Call theStream.WriteText(code)
Dim contentTypeHeader As NotesMIMEHeader
Set contentTypeHeader=body.GetNthHeader("Content-Type")
Dim textPart As NotesMimeEntity
If contentTypeHeader Is Nothing Then
Set textPart=body
Else
If Lcase(contentTypeHeader.GetHeaderVal()) Like "multipart/*" Then
Set textPart=body.CreateChildEntity(body.GetFirstChildEntity())
Else
Set textPart=body
End If
End If
Call textPart.SetContentFromText(theStream, "text/html;charset=UTF-8", ENC_NONE)
End Sub
Sub AddTextBody(code As String)
Dim textPart As NotesMimeEntity
Dim theStream As NotesStream
Set theStream=s.CreateStream()
Call theStream.WriteText(code)
Dim contentTypeHeader As NotesMIMEHeader
Set contentTypeHeader=body.GetNthHeader("Content-Type")
Set textPart=body.CreateChildEntity
Call textPart.SetContentFromText(thestream, "text/html;charset=UTF-8", ENC_NONE)
Call thestream.Truncate
End Sub
'Envoi
Sub send()
Call doc.Send(False)
End Sub
'Set l'envoyeur et envoi
Sub setSenderAndSend(sender As String)
Dim recipients As String
recipients=rcpTo
If rcpCC<>"" Then
If recipients="" Then
recipients=rcpCC
Else
recipients=recipients+","+rcpCC
End If
End If
If rcpBCC<>"" Then
If recipients="" Then
recipients=rcpBCC
Else
recipients=recipients+","+rcpBCC
End If
End If
Call doc.ReplaceItemValue("From",sender)
Call doc.ReplaceItemValue("Recipients",Split(recipients,","))
Call doc.ReplaceItemValue("PostedDate",Now)
Call doc.Save(True, False)
End Sub
'Set le contenu du champ FieldName avec la valeur Fieldvalue
Sub setMailDocItem(fieldName As String, fieldValue As Variant)
Call doc.ReplaceItemValue(fieldName, fieldValue)
End Sub
Function isKnownMimeType(mimeTypeArg As String) As Boolean
isKnownMimeType=False
If Not isMimeInitialized Then Call initMimeTypes()
Forall mt In mimeType
If Listtag(mt)=mimeTypeArg Then
isKnownMimeType=True
Exit Forall
End If
End Forall
End Function
Function getDocument() As NotesDocument
Set getDocument=doc
End Function
Private Sub initMimeTypes()
mimeType("txt")="text/plain"
mimeType("htm")="text/html"
mimeType("html")="text/html"
mimeType("css")="text/css"
mimeType("js")="text/javascript"
mimeType("ics")="text/calendar"
mimeType("gif")="image/gif"
mimeType("jpg")="image/jpeg"
mimeType("jpeg")="image/jpeg"
mimeType("png")="image/png"
mimeType("swf")="application/x-shockwave-flash"
isMimeInitialized=True
End Sub
End Class
Public Class SmartKeyValueMap
Private view As NotesView
Sub new(valueDb As NotesDatabase)
Dim vdb As NotesDatabase
Set vdb=valueDb
If vdb Is Nothing Then
Dim s As New NotesSession
Set vdb=s.CurrentDatabase
End If
Set view=vdb.GetView("Key-Value-Pairs")
If view Is Nothing Then Error 9999, "SmartKeyValueMap object misses the 'Key-Value-Pairs' view. Object will not function and throw errors."
End Sub
Public Function getValue(key As String) As String
Dim entry As NotesViewEntry
Set entry=view.GetEntryByKey(key, True)
If entry Is Nothing Then
getValue=""
Else
getValue=entry.ColumnValues(1)
End If
End Function
Public Function getSmartValue(key As String, default As String)
getSmartValue=getValue(key)
If getSmartValue="" Then
getSmartValue=default
End If
End Function
End Class
Public Class SmartStringTokenizer
Private m_str As String
Private m_delim As String
Private m_pos As Long
Private m_len As Long
Sub new(theStr As String)
m_str=theStr
m_delim=" "
m_pos=1
m_len=Len(m_str)+1
End Sub
Sub setDelimiters(delims As String)
m_delim=delims
End Sub
Function hasMoreTokens() As Boolean
' If Instr(1,m_str,m_delim)>0 Then
If Mid(m_str, m_pos) Like "*[!" & m_delim & "]*" Then
hasMoreTokens=True
Else
hasMoreTokens=False
End If
End Function
Function nextToken() As String
If Not hasMoreTokens() Then Error 9980, "No such element."
Dim beginPos As Long
Dim endPos As Long
beginPos=0
endPos=0
Dim char As String
While (endPos=0) And (m_pos<m_len)
char=Mid(m_str,m_pos,1)
If Instr(m_delim,char)>0 Then
If Not (beginPos=0) Then endPos=m_pos
Else
If beginPos=0 Then beginPos=m_pos
End If
m_pos=m_pos+1
Wend
If endPos=0 Then endPos=m_pos
nextToken=Mid(m_str,beginPos,endPos-beginPos)
End Function
End Class
Utilisation de la classe dans un agent (Use "La class" dans les déclarations) :
- Code : Tout sélectionner
'On fabrique le mail a envoyer en utilisant la classe MIME
Dim DocMail As New SmartMail(session)
Call DocMail.setPrincipal(Expediteur)
'Le sujet
Call DocMail.setSubject("Ici on saisi le sujet du mail")
'La photo de l'entete
Call DocMail.addFileObject(RepertoireTravail+"\RepFichier\"+NomFichier)
'Le corps
Call docmail.addTextBody({<Font size="2" face="Arial"><BR><BR>Hello,</font>} )
Call docmail.addTextBody({<Font size="2" face="Arial"><BR><BR><BR></font>} )
Call docmail.addTextBody({<Font size="2" face="Arial" color=red>The following requests for "Can you help me...? - } +Rubrique+{" have been made this week:<BR><BR><BR></font>} )
'Ajout d'un HREF vers un document de la base.
Chaine = Chaine + {<Font size="2" face="Arial" color=red><A HREF="http://}+nomserver+{/__} + IDAccueil+_
{.nsf/WEBLIEN?Readform&IDB=}+DocREs.IDBASEORI(0) +{&ID=}+DocRes.IDFDOCORI(0)+{&">} + DocRes.TIT(0) +{</A></Font> }
Call docmail.addTextBody(chaine)
Call DocMail.setto(NomUser)
Call DocMail.Send()
si j'avais vu cette classe il y a un an, j'aurai eu je crois moins de galères - merci super -
