Versions : 97 et supérieures
Lorsque le client de messagerie est Lotus Notes, vous pouvez créer un formulaire personnalisé
avec un look "Outlookien", à savoir zones de destinataires, pièces jointes, zone de message...
Un petit bouton pour envoyer et c'est tout.
Procédure globale:
Public Sub SendNotesMail(ByVal Subject As String, _
ByVal Attachment As String, ByVal RECIPIENT As String, _
ByVal CC As String, ByVal BCC As String, _
ByVal BodyText As String, ByVal SaveIt As Boolean)
Dim oMaildb As Object
Dim oMailDoc As Object
Dim oAttachME As Object
Dim oSession As Object
Dim oEmbedObj As Object
Dim sUserName As String
Dim sMailDbName As String
Const STR_ATTACHMENT As String = "Attachment"
On Error GoTo L_ErrCannotCreateNotesSession
Set oSession = CreateObject("Notes.NotesSession")
sUserName = oSession.sUserName
sMailDbName = Left$(sUserName, 1) & Right$(sUserName, _
(Len(sUserName) - InStr(1, sUserName, " "))) & ".nsf"
DoEvents
lblStatus.Caption = "Information about sender..."
Call Sleep(1000)
Set oMaildb = oSession.GETDATABASE(vbNullString, _
sMailDbName)
If oMaildb.IsOpen = True Then
Else
oMaildb.OPENMAIL
End If
Set oMailDoc = oMaildb.CREATEDOCUMENT
oMailDoc.Form = "Memo"
oMailDoc.SENDTO = RECIPIENT
If Len(CC) = 0 Then
Else
oMailDoc.CopyTo = BC
End If
If Len(BCC) = 0 Then
Else
oMailDoc.blindCopyTo = BCC
End If
oMailDoc.Subject = Subject
oMailDoc.Body = BodyText
oMailDoc.SAVEMESSAGEONSEND = SaveIt
DoEvents
lblStatus.Caption = "Looking for attached files..."
Call Sleep(1000)
If Attachment <> vbNullString Then
Set oAttachME = oMailDoc.CREATERICHTEXTITEM_
(STR_ATTACHMENT)
Set oEmbedObj = oAttachME.EMBEDOBJECT(1454, _
vbNullString, Attachment, STR_ATTACHMENT)
oMailDoc.CREATERICHTEXTITEM _
(STR_ATTACHMENT)
End If
DoEvents
oMailDoc.PostedDate = Now()
L_ExCannotCreateNotesSession:
Set oMaildb = Nothing
Set oMailDoc = Nothing
Set oAttachME = Nothing
Set oSession = Nothing
Set oEmbedObj = Nothing
Exit Sub
L_ErrCannotCreateNotesSession:
Select Case Err
Case 429
MsgBox "Impossible de localiser un Client Notes; " & _
"Votre message n'a pas été envoyé !", 16, _
"Lotus Notes requis"
Case Else
MsgBox "Un erreur a empêché l'envoi du message." & _
vbCrlf & "Veuillez en référer à votre administrateur " & _
"pour lui soumettre cette erreur..." & vbCrlf & Error ,_
16, "Error #" & Str(Err)
End Select
Resume L_ExCannotCreateNotesSession
End Sub
Mode d'utilisation:
Sub CreateMemoNotes()
SendNotesMail Me!txtSubject, Me!txtAttachment, Me!txtTo, _
Me!txtCC, Me!txtCCC, Me!txtMessage, False
End Sub
Petit plus:
Me!txtAttachment représente une ligne de chemin complet avec un nom de fichier valide séparé par le séparateur de CommonDialog Control. (La virgule en théorie).
Dans le Formulaire où j'avais exploité ce code, j'avais utilisé un GetOpenFileName() commandé par petit bouton à 3 points (Parcourir...) et qui autorisait une sélection multiple de fichiers.
Déclaration de l'API (A placer en haut de module) :
Private Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000
Fonction d'affichage de la boîte de dialogue des fichiers à joindre
Public Function fnctGetAttachedFiles(ByVal InitialDir _
As String, ByVal Extensions As String, _
ByVal ApplicationName As String) As String
Const MIN_PATH As Integer = 260
Const MAX_PATH As Integer = 8192
Dim oOFN As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
Dim sAttachmentString As String
Dim aApplications() As String
Dim aExtensions() As String
Dim I As Integer
aApplications = Split(ApplicationName, ";")
aExtensions = Split(Extensions, ";")
For I = LBound(aApplications) To UBound(aApplications)
sFilter = sFilter & "Fichiers " & aApplications(I) & _
vbNullChar & aExtensions(I) & vbNullChar
Next
With oOFN
.lStructSize = Len(oOFN)
.hwndOwner = Application.hWndAccessApp
.lpstrFile = Extensions
.lpstrFilter = sFilter
.nFilterIndex = 1
.lpstrFile = String(MIN_PATH, 0)
.flags = OFN_LONGNAMES Or OFN_HIDEREADONLY _
Or OFN_ALLOWMULTISELECT
.nMaxFile = IIf((.flags And OFN_ALLOWMULTISELECT) = _
OFN_ALLOWMULTISELECT, MAX_PATH, MIN_PATH - 1)
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = IIf(Len(InitialDir) = 0, _
Left(Application.CurrentProject.Path, 3), InitialDir)
.lpstrTitle = "Sélection de fichiers en pièces jointes"
End With
lReturn = GetOpenFileName(oOFN)
sAttachmentString = oOFN.lpstrFile
If InStr(1, sAttachmentString, vbNullChar) Then
sAttachmentString = Trim(Left(sAttachmentString, _
InStr(1, sAttachmentString, vbNullChar) - 1))
End If
fnctGetAttachedFiles = sAttachmentString
End Function
Code à affecter au bouton Parcourir...
Sub ShowFileDialog()
Dim sAttachmentString As String
sAttachmentString = fnctGetAttachedFiles("D:\Data", _
"*.doc;*.xls;*.mdb;*.txt", "Word;Excel;Access;Notepad")
If Len(sAttachmentString) > 0 Then
Me!txtAttachment = sAttachmentString
Else
Me!txtAttachment = vbnulstring
End If
End Sub
| 
