Option Explicit
Dim ErrLotus As Boolean
Sub EnvoiBordereau()
Dim DerLig As Long
Dim VPath As String, VFic As String, VPathFic As String
' Initialisation des variables
VPath = ThisWorkbook.Path
' Création d'une copie de la feuille
Sheets("Bordereau").Copy
' Supprimer le bouton sur la feuille copiée
ActiveSheet.Shapes("BtnMail").Delete
' On sauvegarde le nouveau fichier
VFic = "Bordereau envoi PAF du " & Format(Now(), "dd.mm.yyyy hh:mm") & ".xls"
VFic = Replace(VFic, ":", "h")
VPathFic = VPath & "\" & VFic
ActiveWorkbook.SaveAs VPathFic
ActiveWorkbook.Close
' Créer le message LOTUS
ErrLotus = False
Call CreateNotesMsg(VPathFic)
If ErrLotus = True Then Exit Sub
' Effacer ensuite le tableau
DerLig = Range("A" & Rows.Count).End(xlUp).Row
Range("A3:H" & DerLig).ClearContents
End Sub
Sub CreateNotesMsg(VPathFic)
'***********************************************
'Objet : Edition d'un message créé dans Notes
'***********************************************
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim WorkSpace As Object
Dim ntsServer As String
Dim ntsMailFile As String
Dim sSendTo As String, sCopyTo As String
Dim sSubject As String
Dim sBodyText As String
'
On Error GoTo err_CreateNotesMsg
' Initialisation des variables
sSendTo = ThisWorkbook.Sheets("Params").Range("AdrEnvoi")
sCopyTo = ThisWorkbook.Sheets("Params").Range("AdrCopie")
sSubject = "Envoi du " & Format(Now(), "dd.mm.yyyy hh:mm")
'
Set oSess = CreateObject("Notes.NotesSession")
ntsServer = oSess.GetEnvironmentString("MailServer", True)
'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)
' Vérifier si la base est ouverte
If oDB.IsOpen = False Then oDB.OPENMAIL
'
Set oDoc = oDB.CreateDocument
'oDoc.Form = "Memo"
' Inscrire la/les adresse(s) d'envoi
oDoc.AppendItemValue "SendTo", sSendTo
' Eventuellement la/les adresse(s) de copie
If Not IsMissing(sCopyTo) Then
oDoc.AppendItemValue "CopyTo", sCopyTo
End If
' Inscrire le sujet du mail
If Not IsMissing(sSubject) Then
If sSubject <> "" Then oDoc.AppendItemValue "Subject", sSubject
End If
' Créer le corps du message
Set oItem = oDoc.CreateRichTextItem("BODY")
' Inscire le texte
With oItem
.AppendText "Bonjour,"
.AddNewline 1
.AppendText "Vous trouverez ci-joint le bodereau d'envoi,"
.AppendText "ainsi que les PAF signés"
.AddNewline 1
End With
' Attacher le fichier de bordereau
Call oItem.EmbedObject(1454, "", VPathFic, "Attachement")
' Ouvrir l'espace de travail
'Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
'Call WorkSpace.EditDocument(True, oDoc)
' ou Envoyer le Mail
Call oDoc.Send(False)
exit_CreateNotesMsg:
On Error Resume Next
Set oItem = Nothing
Set oDoc = Nothing
Set oDB = Nothing
Set oSess = Nothing
Exit Sub
err_CreateNotesMsg:
ErrLotus = True
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_CreateNotesMsg
End Sub
