Sub Macro1()
'
' Macro1 Macro
' Macro écrit le 14/04/2008 par aozel
'
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim ntsServer As String
Dim ntsMailFile As String
'
Dim EMailSendTo As String
Dim EMailCopyTo As String
Dim EMailSubject As String
Dim MailPJ As String
Dim LotusSRV As String
Dim WbkName As String
Dim i As Byte
Dim adresses As String
On Error GoTo err_SendNotesMsg
' Initialisation des variables
EMailSendTo = Split("ozelasim@free.fr,
as_turc@hotmail.fr", ",") 'liste de diffusion
For i = 0 To UBound(EMailSendTo)
adresses = adresses & EMailSendTo(i) & ";"
Next i
MsgBox Left(adresses, Len(adresses) - 1)
EMailCopyTo = "" 'liste de diffusion en copie
EMailSubject = "Suivi des convocations clients" 'sujet du mail
' Créer une nouvelle session Notes
Set oSess = CreateObject("Notes.NotesSession")
ntsServer = oSess.GetEnvironmentString("YN34BEL/BTA/EMG/PGD", True) 'nom du serveur de lotus
'Acquière le nom du fichier mailfile de l'utilisateur courant dans Notes.ini
ntsMailFile = oSess.GetEnvironmentString("MailFile", True)
Set oDB = oSess.GetDatabase(ntsServer, ntsMailFile)
Set oDoc = oDB.CreateDocument
' Définit les éléments à rajouter au message
Set oItem = oDoc.createRichTextItem("BODY")
oDoc.Form = "Memo"
' Préparer les destinataires
oDoc.Sendto = EMailSendTo
If Not IsMissing(EMailCopyTo) Then
oDoc.Copyto = EMailCopyTo
End If
' Préparer le sujet du message
If Not IsMissing(EMailSubject) Then
If EMailSubject <> "" Then oDoc.Subject = EMailSubject
End If
oDoc.FROM = oSess.CommonUserName
oDoc.PostedDate = Date
' Pour avoir un accusé de réception
oDoc.ReturnReceipt = "1"
' Préparer le texte qui figurera dans le message
With oItem
.AppendText "TABLEAU DE SUIVI DES CONVOCATIONS CLIENTS AFFAIRE H2"
.AddNewline 1
.AppendText "*********************************************************************************"
.AddNewline 2
.AppendText "Des convocations clients ont été ajoutées pour l'affaire" & Cells(1, 1)
.AddNewline 1
.AppendText "N'oubliez pas de remplir les dates de convocations sur cette affaire"
.AddNewline 2
.AppendText "rendez-vous dans le répertoire ci-dessous pour consulter les convocations"
.AddNewline 2
.AppendText "G:\SMG\Commun\0 SUIVI DES CONVOCATIONS CLIENTS"
.AddNewline 1
.AppendText "--------------------------------------------------------------------------------------------------------"
.AddNewline 2
.AppendText "Cellule Vert: Date de lancement de convocation compris entre -10 et -5 jours "
.AddNewline 1
.AppendText "Cellule Jaune: Date de lancement de convocation compris entre -5 et -1 jours"
.AddNewline 1
.AppendText "Cellule Rouge: Date de lancement de convocation compris entre -1 et +2 jours"
.AddNewline 2
.AppendText "Cet e-mail a été généré par un processus automatique."
.AddNewline 2
End With
' Créer la pièce jointe
' Ca peut être le classeur
WbkName = ThisWorkbook.FullName
'Attachement du classeur au mail
Call oItem.embedObject(1454, "", WbkName, "")
' Ou Attachement d'un document
'Call oItem.embedObject(1454, "", "Chemin et nom complet du doc","")
' Message de salutation
oItem.AddNewline 1
oItem.AppendText "Cordialement"
oItem.AddNewline 2
oItem.AppendText "Asim OZEL"
' Envoyer le message
oDoc.send False
' confirmation de l'envoi du message
MsgBox "Le message a été envoyé", vbInformation, "MESSAGE LOTUS ..."
'message d'erreur
exit_SendNotesMsg:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
Exit Sub
err_SendNotesMsg:
If Err.Number = 7225 Then
MsgBox "Impossible d'attacher le fichier, vérifier le chemin!", vbCritical
Else
MsgBox "[" & Err.Number & "]: " & Err.Description
End If
MsgBox "Message non envoyé suite erreur!", vbCritical
Resume exit_SendNotesMsg
'
End Sub
