Sub Gestion_Mail()
'Préparation de l'envoi de Mail
'Ici l'on régle tout
Dim Sujet As String, Message As String, Fichier As String, Destinataire As String
Dim Copie As String, CopieCachée As String, Chemin As String
Dim Condition As Boolean, Apercu As Boolean, Alerte As Boolean
'******** ** * Tous ceci est à adapter * ** ************
Sujet = "Envoi Facture " & Sheets("Facture").Range("C7").Text 'titre du mail
Message = "Voici la Facture " & Sheets("Facture").Range("C7").Text & " du " & Date ' Message dans le mail
Chemin = "c:\temp\" 'Répertoire de travail
Fichier = Chemin & "pj_du_" & Replace(Date, "/", "-") & ".xlsx" 'Emplacement et nom du fichier de Sauvegarde provisoire
Destinataire = Sheets("Réglages").Range("L7") 'adresse mail Destinataire principal
Copie = "" 'Destinataire en copie
CopieCachée = "" 'Destinataire en copie cachée
Apercu = False 'True ' Autorise la prévisualisation
'Ici somme les conditions minimum pour envoi du courrier, sinon laisser à vrai
'ex : Condition = IIf(Message <> "", True, False)
Condition = True
Alerte = True 'Permet d'obtenir un popup si anomalie pas de destinataire avant la sortie sans envoi
'Fin des réglages ************************
'Prépare la sauvegarde de la pièce jointe
Sheets("pj").Select 'Saisir le nom exact la feuille
ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Fichier 'Sauvegarde Feuille
Application.DisplayAlerts = True
ActiveWorkbook.Close False
'Transfert vers la routine Courrier
If Condition Then Courrier Sujet, Message, Fichier, Destinataire, Apercu, Alerte, Copie, CopieCachée
ThisWorkbook.Save
'Supprime le fichier temporaire
Kill Fichier
End Sub
Sub Courrier(Sujet As String, Message As String, Fichier As String, Destinataire As String, _
Apercu As Boolean, Alerte As Boolean, Optional Copie As String, Optional CopieCachée As String)
'Envoi de mail via Outlook
'*********************** ICI ne rien toucher *********************************
Dim Appli_Outlook As Object, Mail_Outlook As Object
Dim NS As Object 'Namespace
Dim Envoi As Variant
Dim Temps_Max As Double
'Ne doit jamais planter
On Error GoTo Sortie
'Initialise
Set Appli_Outlook = CreateObject("Outlook.Application")
Set Mail_Outlook = Appli_Outlook.CreateItem(0)
With Mail_Outlook
If InStr(Destinataire, "@") > 0 Then
.To = Destinataire
Else
If Alerte Then MsgBox "Pas de destinataire"
GoTo Sortie
End If
If InStr(Copie, "@") > 0 Then .CC = Copie
If InStr(CopieCachée, "@") > 0 Then .BCC = CopieCachée
.Subject = Sujet
.BodyFormat = 1 'olFormatPlain
.Body = Message
'.Importance = 2 'olImportanceHigh
'.Sensitivity = 3 'olConfidential
If Fichier <> "" And Dir(Fichier) <> "" Then .Attachments.Add Fichier
If Apercu Then .Display 'Si demandé , propose l'aperçu du Mail
If Not Apercu Then .Send 'envoye du mail
'
End With
'Attente envoi message
Temps_Max = Timer + 0.5 * 60
Set NS = Appli_Outlook.GetNamespace("MAPI")
Do
Set Envoi = NS.GetDefaultFolder(4) ' olFolderOutbox = 4 (Boite d'envoi)
Loop Until Envoi.Items.Count = 0 Or Timer > Temps_Max
Sortie:
'Réactive la gestion d'erreur par Excel
On Error GoTo 0
Set Mail_Outlook = Nothing
Set Appli_Outlook = Nothing
End Sub
Sub ListeBoiteDEnvoi()
Dim Appli_Outlook As Object, Mail_Outlook As Object
'Initialise
Set Appli_Outlook = CreateObject("Outlook.Application")
Dim NS As Object 'Namespace
Dim Envoi
Set NS = Appli_Outlook.GetNamespace("MAPI")
Set Envoi = _
NS.GetDefaultFolder(4) '(olFolderOutbox) '4
MsgBox "Nombre de messages : " & Envoi.Items.Count
End Sub