Macro pour envoyer mail à partir de outlook

matthieu2701

XLDnaute Occasionnel
Bonjour,

J'ai une macro pour l'envoi de mail à partir de Lotus notes. Nous venons de changer de messagerie et je suis passer sous outlook.

J'aurais besoin de votre aide pour modifier ma macro pour qu'elle fonctionne sous outlook.

Je vous remercie par avance de votre aide.

Code:
Public Sub Lancement_LARO241242()
Call RoutineEnvoiMailLotus_LARO241242
End Sub

Public Sub RoutineEnvoiMailLotus_LARO241242()
 Application.ScreenUpdating = False

'Perso, je préfère définir des noms sur les cellules plutot que d'utiliser B1, B2...
 With Sheets("Echéancier")
     Ref = .Range("B1")
     Nom = .Range("B2")
     Adresse = .Range("B3")
     Dette = .Range("D1")
     PCE = .Range("G6")
     Compteur = .Range("G7")
     Matricule = .Range("G8")
     Téléphone = .Range("G9")
     Commentaire = .Range("G10")
     Centre = .Range("G5")
     Champ1 = "N° de PCE------------------------ : "
     Champ2 = "IGOR------------------------------- : "
     Champ3 = "Nom du client----------------- : "
     Champ4 = "Adresse de livraison------- : "
     Champ5 = "Téléphone du client------- : "
     Champ6 = "Compteur sur place------- : "
     Champ7 = "         matricule : "
     Champ8 = "Montant------------------------ : "
     Champ9 = "Echéancier------------------- : "
     Champ10 = "Commentaire--------------- : "
      ObjetMailFige = .Range("G14")
     ObjetMailLibre = .Range("G15")
 End With

 With Sheets("Echéancier")
 If Centre = 251 Or Centre = 252 Or Centre = 256 Or Centre = 258 Or Centre = 253 Or Centre = 254 Or Centre = 259 Or Centre = 243 Or Centre = 245 Then
     MsgBox "Centre incorrect", vbCritical, "Attention"
     Exit Sub
 End If
 If PCE = "" Or Compteur = "Oui" And Matricule = "" Or Téléphone = "" Or Commentaire = "" Or Ref = "" Or Nom = "" Or Adresse = "" Or Dette = "" Then
 MsgBox "Veuillez Remplir tous les champs avant d'envoyer le mail", vbOKOnly + vbCritical, "Attention"
 Exit Sub
 Else
 
 'NNI des agents
'Marignane
Matthieu = "B....."
Yacine = "J....."
Sophie = "d...."
Maxence = "J....."
Remi = "f......"
Camille = "c......"
Cindy = "c....."
Sarah = "s......"
Priscilla = "d...."
Priscilla2 = "D...."
Zoe = "F...."
Elodie = "d...."
Virginie = "D...."
Daniel = "h....."
Nathalie = "b...."
Alexandre = "i...."
Stephane = "a...."
Florent = "C...."
Anais = "G...."
Paola = "e...."
Sanae = "A...."
Marine = "F...."
AnaisG = "h...."

'Nimes
Claudia = "j...."
Magali = "J...."
Karina = "J...."
Eric = "J...."
Celine = "A...."
Betty = "A...."

'Recherche de l'utilisateur qui a ouvert la session
utilisateur = Environ("username")
Select Case utilisateur

Case Matthieu, Yacine, Sophie, Maxence, Remi, Camille, Cindy, Sarah, Priscilla, Priscilla2, Zoe, Elodie, Daniel, Nathalie, Alexandre, Stephane, Florent, Anais, Paola, Sanae, Marine, AnaisG
    chemin = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE
    chemin2 = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\"
    fichier = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE & "\" & Nom & " Engagement de Paiement.docx"
Case Virginie
    chemin = "G:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE
    chemin2 = "G:\AAGP2\PDD GAZ\PDD\Dossiers PDD\"
    fichier = "G:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE & "\" & Nom & " Engagement de Paiement.docx"
Case Fabienne, Claudia, Magali, Karina, Eric, Celine, Betty
   chemin = "Q:\AAG\DOSSIERS NUMERIQUES PDD" & "\" & Nom & " " & PCE
   chemin2 = "Q:\AAG\DOSSIERS NUMERIQUES PDD\"
   fichier = "Q:\AAG\DOSSIERS NUMERIQUES PDD" & "\" & Nom & " " & PCE & "\" & Nom & " Engagement de Paiement.docx"

End Select
 
If Dir(fichier, vbDirectory) = "" Then
MsgBox "Le dossier numérique ou l'engagement de paiement de " & Nom & " " & PCE & " n'a pas été créé. Veuillez le créer puis recommencer", vbCritical, "Attention"
Exit Sub
End If

'Application.DisplayAlerts = False '(utiliser aussi pour le sauvegarde)
'ActiveWorkbook.SaveAs Filename:="C:\TEMP\" + NomFichier, FileFormat _
':=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
'False, CreateBackup:=False
'Application.DisplayAlerts = True


'DEFINITION DES DONNEES POUR L'ENVOI DU MESSAGE

'Gestionnaire Habilitation
'tu peux ici déclarer tes variables pour les utiliser pour les destinataires, ou personnes en copie etc.
'Destintaire2 = Sheets("Demande").Range("Destinatarie2").Value
'AutreDestinaire = Sheets("Demande").Range("AutreDestinataire2").Value

Sujet = ObjetMailFige & ObjetMailLibre '

Destinataires(0) = "test@hotmail.fr"
'Destinataires(1) = ""
'--------------------------------------------------------
'Personne en copie
ccDestinataires(0) = ""
'ccDestinataires(1) = Destintaire2
'--------------------------------------------------------
'--------------------------------------------------------
'Personne en copie cachée
cccDestinataires(0) = ""
'cccDestinataires(1) = AutreDestinaire
'--------------------------------------------------------
fichier1 = Nom & " Engagement de Paiement.docx" ' "NomDuFichier.xls"
If chemin > "" And Right(chemin, 1) <> "\" Then chemin = chemin & "\"
FichierJoint = chemin & fichier1
Fichier2 = "RIB GRDF.pdf"
FichierJoint2 = chemin2 & Fichier2

'RECUPERATION DE LA SESSION NOTES
Call SendNotesMail

'Si erreur dans le module Init_Notes alors on revient ici et on affiche le message sinon on continue
'If Retour = ERR_NOTES_ERROR Then
'MsgBox " Erreur lors de l'ouverture de la session ", vbExclamation, " Problème "
'Exit Sub
'End If

' Création du message
Set LeMail = BaseMail.CreateDocument

'Déclarations pour la mise en forme du texte (gras, italic...)
Set rtstyle = Session.CreateRichTextStyle
Set rtstyle2 = Session.CreateRichTextStyle
Set colorObject = Session.CreateColorObject

Call LeMail.AppendItemValue("Form", "Memo")
Call LeMail.AppendItemValue("sendTo", Destinataires)
Call LeMail.AppendItemValue("CopyTo", ccDestinataires)
Call LeMail.AppendItemValue("BlindCopyTo", cccDestinataires)
Call LeMail.AppendItemValue("Subject", Sujet)

'LeMail.SaveMessageOnSend = True
Set Body = LeMail.CreateRichTextItem("Body")

'******************************************************************************
'Personnalisation du message envoyé
rtstyle.Bold = True
rtstyle.Italic = True
rtstyle.NotesFont = 2
rtstyle.FontSize = 10
rtstyle2.Bold = False
rtstyle2.Italic = False
'******************************************************************************
'Message$ = "Bonjour," & vbCrLf & vbCrLf & "Je t 'envoie les informations concernant le rétablissement gaz suite PDD." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
'"1 - IDENTIFICATION DU CLIENT / DEMANDE" & _
'vbCrLf & vbCrLf & vbCrLf & vbCrLf & Champ1 & PCE & vbCrLf & vbCrLf & Champ2 & Ref & vbCrLf & vbCrLf & Champ3 & Nom & vbCrLf & vbCrLf & Champ4 & Adresse & vbCrLf & vbCrLf & Champ5 & _
'"0" & Téléphone & vbCrLf & vbCrLf & Champ6 & Compteur & "      " & Champ7 & Matricule & vbCrLf & vbCrLf & Champ8 & FormatNumber(Dette, 2) & vbCrLf & vbCrLf & Champ9 & _
'"Voir PiÃ_ce jointe" & vbCrLf & vbCrLf & Champ10 & Commentaire & vbCrLf & vbCrLf & "Cordialement" 'message
' Fichier$ = Nom & " Engagement de Paiement.docx" ' "NomDuFichier.xls"
' Chemin$ = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours\" & "\" & Nom & " " & Ref ' chemin du fichier exp: = ThisWorkbook.Path
' If Chemin$ > "" And Right(Chemin$, 1) <> "\" Then Chemin$ = Chemin$ & "\"

Call Body.AppendText("Bonjour,")
Call Body.AddNewLine(2)
Call Body.AppendText("Je t 'envoie les informations concernant le rétablissement gaz suite PDD.")
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText("------------------------------------------------------------------------------------------------------------------------------------")
Call Body.AppendStyle(rtstyle2)
Call Body.AddNewLine(1)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText("                          1 - IDENTIFICATION DU CLIENT / DEMANDE")
Call Body.AppendStyle(rtstyle2)
Call Body.AddNewLine(1)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText("------------------------------------------------------------------------------------------------------------------------------------")
Call Body.AppendStyle(rtstyle2)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ1)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(PCE)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ2)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Ref)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ3)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Nom)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ4)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Adresse)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ5)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Format(Téléphone, "0000000000"))
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ6)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Compteur)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ7)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Matricule)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ8)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(FormatNumber(Dette, 2))
Call Body.AppendText(" euros")
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ9)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText("Voir pièce jointe")
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(Champ10)
Call Body.AppendStyle(rtstyle2)
Call Body.AppendText(Commentaire)
Call Body.AddNewLine(2)
Call Body.AppendStyle(rtstyle)
Call Body.AppendText("------------------------------------------------------------------------------------------------------------------------------------")
Call Body.AppendStyle(rtstyle2)
Call Body.AddNewLine(2)
Call Body.AppendText("Bonne Réception.")
Call Body.AddNewLine(2)
Call Body.AppendText("Cordialement")
Call Body.AddNewLine(2)
'tu ouvres avec ce style
Call Body.AppendStyle(rtstyle)
Call Body.AppendText(EmetteurA)
'tu fermes avec ce style
Call Body.AppendStyle(rtstyle2)
Call Body.AddNewLine(2)
LeMail.SaveMessageOnSend = True

LeMail.SaveMessageOnSend = True
'Prend en compte les pièces jointes
If FichierJoint <> "" Then
Set AttachME = LeMail.CreateRichTextItem("Attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", FichierJoint, "Attachment")
End If
If Range("I7") = "virement" Then
Set EmbedObj = AttachME.EmbedObject(1454, "", FichierJoint2, "Attachment")
End If

'Envoie le mail
LeMail.Send 0

'LIBERE LES OBJETS
Call Fin_Notes_Envoi

ActiveSheet.Shapes("MonBouton").Visible = True
Application.OnTime Now + TimeValue("00:00:02"), "EffacerMessage8"

Erase Destinataires()
Erase ccDestinataires()
Erase cccDestinataires()

End If
End With
End Sub
Sub EffacerMessage8()
ActiveSheet.Shapes("MonBouton").Visible = False
MsgBox "Avez-vous pensez à appeler la CPC pour programmer l'intervention ?", vbCritical, "Attention"
Sheets("Echéancier").Range("K1").Value = Format(Now, "dddd dd mmmm yyyy / h:mm")
Sheets("Echéancier").Range("K2").Value = Environ("username")
Call Enregistrer_Classeur
Sheets("Echéancier").Range("K4").Value = Format(Now, "dddd dd mmmm yyyy / h:mm")
End Sub
 
Dernière édition:

matthieu2701

XLDnaute Occasionnel
Re : Macro pour envoyer mail à partir de outlook

C'est bizarre car cela fonctionne parfaitement à mon boulot. Je comprends pas pourquoi il a lit les élections en Z. Je viens de regarder et les é sont noté correctement chez moi. Je le reposte.
 

Pièces jointes

  • PDD.xlsm
    82 KB · Affichages: 39
Dernière édition:

matthieu2701

XLDnaute Occasionnel
Re : Macro pour envoyer mail à partir de outlook

Bonjour,

Voici le fichier modiifée et la capture d'écran du mail qui doit être généré.

Merci par avance.
 

Pièces jointes

  • Gaz-Perd Test.xlsm
    107.5 KB · Affichages: 40
  • Capture Mail PDD.jpg
    Capture Mail PDD.jpg
    38.6 KB · Affichages: 44
Dernière édition:

matthieu2701

XLDnaute Occasionnel
Re : Macro pour envoyer mail à partir de outlook

Bonjour à tous

mattieu2701
Je passe le relais pour la journée à mes petits camarades de jeu du forum
car là je dois aller au taf.
Je repasserai dans ton fil ce soir ou durant le week-end.

En attendant de l'aide des XLDnautes, je t'invite à faire des recherches dans les discussions relatives à l'envoi de mail par outlook
(qui sont accessibles par le biais du moteur de recherche interne du forum - la loupe en haut à droite)

Voir aussi le site web de Ron de Bruin (tout bon moteur de recherche saura t'y mener)

Merci pour ces infos.
 

matthieu2701

XLDnaute Occasionnel
Re : Macro pour envoyer mail à partir de outlook

Bonjour,

Je viens de tester. Le nouveau mail se crée mais ne s'envoie pas. Il reste à l'écran. Les champs ne sont pas complétés et les pièces ne sont pas jointes. Voici mon code modifié.

Code:
Public Sub Lancement_LARO241242()
Call RoutineEnvoiMailLotus_LARO241242
End Sub

Public Sub RoutineEnvoiMailLotus_LARO241242()
 Application.ScreenUpdating = False

'Perso, je préfère définir des noms sur les cellules plutot que d'utiliser B1, B2...
 With Sheets("Echéancier")
     Ref = .Range("B1")
     Nom = .Range("B2")
     Adresse = .Range("B3")
     Dette = .Range("D1")
     PCE = .Range("G6")
     Compteur = .Range("G7")
     Matricule = .Range("G8")
     Téléphone = .Range("G9")
     Commentaire = .Range("G10")
     Centre = .Range("G5")
     Champ1 = "N° de PCE------------------------ : "
     Champ2 = "IGOR------------------------------- : "
     Champ3 = "Nom du client----------------- : "
     Champ4 = "Adresse de livraison------- : "
     Champ5 = "Téléphone du client------- : "
     Champ6 = "Compteur sur place------- : "
     Champ7 = "         matricule : "
     Champ8 = "Montant------------------------ : "
     Champ9 = "Echéancier------------------- : "
     Champ10 = "Commentaire--------------- : "
      ObjetMailFige = .Range("G14")
     ObjetMailLibre = .Range("G15")
 End With

 With Sheets("Echéancier")
 If Centre = 251 Or Centre = 252 Or Centre = 256 Or Centre = 258 Or Centre = 253 Or Centre = 254 Or Centre = 259 Or Centre = 243 Or Centre = 245 Then
     MsgBox "Centre incorrect", vbCritical, "Attention"
     Exit Sub
 End If
 If PCE = "" Or Compteur = "Oui" And Matricule = "" Or Téléphone = "" Or Commentaire = "" Or Ref = "" Or Nom = "" Or Adresse = "" Or Dette = "" Then
 MsgBox "Veuillez Remplir tous les champs avant d'envoyer le mail", vbOKOnly + vbCritical, "Attention"
 Exit Sub
 Else
 
 'NNI des agents
'M
Matthieu = "B"

'N
Fabienne = "f...."


'Recherche de l'utilisateur qui a ouvert la session
utilisateur = Environ("username")
Select Case utilisateur

Case Matthieu
    chemin = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE
    chemin2 = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\"
    fichier = "Q:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE & "\" & Nom & " Engagement de Paiement.docx"
Case Virginie
    chemin = "G:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE
    chemin2 = "G:\AAGP2\PDD GAZ\PDD\Dossiers PDD\"
    fichier = "G:\AAGP2\PDD GAZ\PDD\Dossiers PDD\En cours" & "\" & Nom & " " & PCE & "\" & Nom & " Engagement de Paiement.docx"
Case Fabienne
   chemin = "Q:\AAG\DOSSIERS NUMERIQUES PDD" & "\" & Nom & " " & PCE
   chemin2 = "Q:\AAG\DOSSIERS NUMERIQUES PDD\"
   fichier = "Q:\AAG\DOSSIERS NUMERIQUES PDD" & "\" & Nom & " " & PCE & "\" & Nom & " Engagement de Paiement.docx"

End Select
 
If Dir(fichier, vbDirectory) = "" Then
MsgBox "Le dossier numérique ou l'engagement de paiement de " & Nom & " " & PCE & " n'a pas été créé. Veuillez le créer puis recommencer", vbCritical, "Attention"
Exit Sub
End If

'Application.DisplayAlerts = False '(utiliser aussi pour le sauvegarde)
'ActiveWorkbook.SaveAs Filename:="C:\TEMP\" + NomFichier, FileFormat _
':=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
'False, CreateBackup:=False
'Application.DisplayAlerts = True


'DEFINITION DES DONNEES POUR L'ENVOI DU MESSAGE

'Gestionnaire Habilitation
'tu peux ici déclarer tes variables pour les utiliser pour les destinataires, ou personnes en copie etc.
'Destintaire2 = Sheets("Demande").Range("Destinatarie2").Value
'AutreDestinaire = Sheets("Demande").Range("AutreDestinataire2").Value

Dim objOLK As Outlook.Application, oEmail As Outlook.MailItem
 
Set objOLK = New Outlook.Application: Set oEmail = objOLK.CreateItem(olMailItem)
With oEmail
.To = ""
.CC = ""
.BCC = ""
.Subject = ObjetMailFige & ObjetMailLibre
.BodyFormat = olFormatHTML
'demande un accusé de réception
.OriginatorDeliveryReportRequested = True
 'demande un accusé de lecture
.ReadReceiptRequested = True
.HTMLBody = "<HTML><body>Bonjour," & "<br><br>"
.HTMLBody = .HTMLBody & "Je t'envoie les informations concernant le rétablissement gaz suite PDD.<br> <br>"
.HTMLBody = .HTMLBody & "<center>------------------------------------------------------------------------------------------------------------------------------------<br><br>"
.HTMLBody = .HTMLBody & "1 - IDENTIFICATION DU CLIENT / DEMANDE<br> <br>"
.HTMLBody = .HTMLBody & "------------------------------------------------------------------------------------------------------------------------------------</center><br><br>"
.HTMLBody = .HTMLBody & Champ1 & "<br>"
.HTMLBody = .HTMLBody & Champ2 & "<br>"
.HTMLBody = .HTMLBody & Champ3 & "<br>"
.HTMLBody = .HTMLBody & Champ4 & "<br>"
.HTMLBody = .HTMLBody & Champ5 & "<br>"
.HTMLBody = .HTMLBody & Champ6 & "<br>"
.HTMLBody = .HTMLBody & Champ7 & "<br>"
' je te laisse continuer sur le même principe
.HTMLBody = .HTMLBody & "Bonne Réception." & "<br> <br>" & "Cordialement" & "</body></HTML>"
.Display
End With
Set objOLK = Nothing
'Prend en compte les pièces jointes
If FichierJoint <> "" Then
Set AttachME = LeMail.CreateRichTextItem("Attachment")
Set EmbedObj = AttachME.EmbedObject(1454, "", FichierJoint, "Attachment")
End If
If Range("I7") = "virement" Then
Set EmbedObj = AttachME.EmbedObject(1454, "", FichierJoint2, "Attachment")
End If

'Envoie le mail
'LeMail.Send 0

'LIBERE LES OBJETS
'Call Fin_Notes_Envoi

ActiveSheet.Shapes("MonBouton").Visible = True
Application.OnTime Now + TimeValue("00:00:02"), "EffacerMessage8"

'Erase Destinataires()
'Erase ccDestinataires()
'Erase cccDestinataires()

End If
End With
End Sub
Sub EffacerMessage8()
ActiveSheet.Shapes("MonBouton").Visible = False
MsgBox "Avez-vous pensez à appeler la CPC pour programmer l'intervention ?", vbCritical, "Attention"
Sheets("Echéancier").Range("K1").Value = Format(Now, "dddd dd mmmm yyyy / h:mm")
Sheets("Echéancier").Range("K2").Value = Environ("username")
Call Enregistrer_Classeur
Sheets("Echéancier").Range("K4").Value = Format(Now, "dddd dd mmmm yyyy / h:mm")
End Sub

Je joins également la capture du mail qui est généré.
 

Pièces jointes

  • Capture Mail outlook.jpg
    Capture Mail outlook.jpg
    37.3 KB · Affichages: 34
Dernière édition:

matthieu2701

XLDnaute Occasionnel
Re : Macro pour envoyer mail à partir de outlook

Désolé. Je testerais avec .Send. Mais si je note .Send à la place de .Display le mail va partir sans les pièces jointes.

Je vais voir pour incorporer l'envoi des pièces jointes. J'ai trouvé ca :

Code:
Sub AddAttachment() 
 Dim myItem As Outlook.MailItem 
 Dim myAttachments As Outlook.Attachments 
 
 Set myItem = Application.CreateItem(olMailItem) 
 Set myAttachments = myItem.Attachments 
 myAttachments.Add "C:\Test.doc", _ 
 olByValue, 1, "Test" 
 myItem.Display 
End Sub