Envoi mail en vba avec corps message Résolu

Question

Bonjour, 

Je voudrai inclure un corps de message à mon envoi du classeur en fichier joint via excel en vba. 
J'ai une macro où il y a bien le corps du message mais pas le fichier joint. 
J'ai essayé de combiner avec d'autres formules mais je n'y arrive pas. 
Quelqu'un pourrait me dire ce qui cloche. Merci
Voici la macro:

Sub EnvoiFeuilCalculMail()

Dim Copie As String
Dim Destinataire As String
Dim ObjetMessage As String
Dim CorpsMessage As String
Dim EnvoiDirect As Boolean


Set Wbk = ActiveWorkbook

ObjetMessage = "P1 du " & Range("H4").Value
Destinataire = Range("G68").Value
Copie = Range("G72").Value

'Désactivation de la mise à jour de l'écran
Application.ScreenUpdating = False

'Crée le corps du message avec insertion de sauts de ligne
CorpsMessage = "Bonjour Olivier" & vbCrLf & vbCrLf _
& "Veuillez trouvez ci-joint le P1" & Range("C74").Value & vbCrLf & vbCrLf _
& "Cordialement " & vbCrLf _
& "Prénom Nom " & vbCrLf _
& "Grade" & vbCrLf & vbCrLf _
& "Etablissement " & vbCrLf _
& Range("G74").Value & vbCrLf _
& Range("G75").Value & vbCrLf _
& Range("G76").Value & vbCrLf & vbCrLf _
& Range("G68").Value & vbCrLf _


'Demande à l'utilisateur s'il souhaite ou non vérifier le mail
If MsgBox("Souhaitez-vous envoyer le mail directement sans vérification ?", 36, "Confirmation") = 6 Then
EnvoiDirect = True
Else
EnvoiDirect = False
End If

'Lance le programme Outlook Express
Shell "C:\Program Files\Outlook Express\msimn.exe " & _
"/mailurl:mailto:" & Destinataire & _
"?subject=" & ObjetMessage & _
"&Body=" & CorpsMessage, vbMaximizedFocus


'Message confirmant l'envoi du mail avec précision de l'heure d'envoi
MsgBox "Message envoyé avec Outlook Express à " & Format(Time(), "hh:mm"), vbOKOnly, "Opération réussie"

'Réactivation de la mise à jour de l'écran
Application.ScreenUpdating = True

Range("B9").Select

End Sub 

Configuration: Windows XP / Internet Explorer 8.0

Mike-31 · Accepted Answer

Salut,

Dans une dicussion récente, j'ai écrit ce code qui n'utilise aucune messagerie (Oulook, Incredimail etc...) et passe directement par le SMTP.
Ce code enregistre une feuille Excel nommée Devis en PDF, envoi cette feuille et supprime la feuille PDF générée.
J'ai inclu dans le code une msgbox qui affiche les erreurs éventuelles, ce code peut être modifié et adapté aux besoins (garder l'extension XLS, PDF, TXT etc..., conserver le fichier généré ou ne pas le créer, envoyer une feuille ou tout le classeur etc ...)


Sub main()
Dim messageHTML
On Error GoTo errorHandler
               'on cré le fichier PDFdans le même dossier que le fichier source
Sheets("Devis").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        ActiveWorkbook.Path & "\" & [B11] & [C13] & ".PDF" '"Devis.pdf"

Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Sujet du Message"
objMessage.From = "xxx.xxxxxx@free.fr"         'adresse mail de l'expéditeur n'est pas obligatoire
objMessage.To = "xxxx.xxxxxxx@free.fr"     'Email du destinataire doit-être correct ici
objMessage.TextBody = "Bonjour," & vbCrLf & "Veuillez trouver en piéce jointe votre facture" & vbCrLf & "en votre aimable réglement"
piece_jointe = ActiveWorkbook.Path & "\" & [B11] & [C13] & ".PDF" '& "Devis.pdf"
''piece_jointe = "C:\Documents and Settings\Les Lagouanère\Bureau\0917_001.pdf"  'chemin du fichier à envoyer en piéce-jointe
'piece_bis = "C:\Documents and Settings\Les Lagouanère\Bureau\Cligno.xls"      ' Si on souhaite envoyer plusieurs pièces les déclarer
messageHTML = "Ceci est un message en HTML"

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update

objMessage.AddAttachment (piece_jointe) 'On ajoute la piéce jointe, il est possible d'envoyer plusieurs pièces
'objMessage.AddAttachment (piece_bis)   'dans ce cas on ajoute un objMessage.AddAttachement () par pièce
objMessage.Send
    MsgBox "Le mail a été bien envoyé !" ', 64, "Information"
     'après l'envoi la feuille PDF est supprimée
Kill ActiveWorkbook.Path & "\" & [B11] & [C13] & ".PDF" '"Devis.pdf"
    'si erreur on sort de la procédure
   Exit Sub
errorHandler:
    'description de l'erreur survenue
    MsgBox Err.Description
 End Sub

Info · Answer

Bonjour, Voici un exemple différent pour envoyer un courriel avec pièce jointe en VBA : Option Explicit ' Procédure Envoi_Courriel ' Michel Blais ' Création : Samedi, le 22 Décembre 2007 ' Modifier : ' Version 2.0.0 ' Utilisation de OutlookExpress pour courrier sortant ' Sortie : Notification d'automatisme ' Déclaration de constantes Const cteLecture = 1 Const cteEcriture = 2 Const cteAjouter = 8 Const cteAdresseSource = "mon.nom@serveur.net" Const cteAdresseDefaut = "ton.nom@serveur.net" ' ' Paramètre [ Boite ] ' Boite(0) -> "destination@serveur.net" ' Adresse courriel de destination ' Boite(1) -> "Automatisme" ' Titre du message ' Boite(2) -> "Message" ' Texte du message ' Boite(3) -> "Fichier.txt" ' Fichier joint ' Boite(4) -> "True" ' Indice d'inclusion de la pièce jointe Sub Envoi_Courriel() Dim BigBox(0 To 5) As Variant BigBox(0) = "Mon.Adresse@monserveur.net" BigBox(1) = "Automatisme" BigBox(2) = "Contenu du message" BigBox(3) = "Rapport.txt" BigBox(4) = "False" BigBox(5) = ThisWorkbook.Path & "\" & BigBox(3) Call Master(BigBox) End Sub ' Sub Master(Boite) ' Déclaration de variables Dim objMail As Object Dim sDestination As String, sPieceJointe As String Dim msgTitre As String, msgTexte As String Dim Drapeau As Boolean Set objMail = CreateObject("CDO.Message") 'set objMail = Server.CreateObject("CDO.Message") Drapeau = False If (UBound(Boite) > 0) Then If (Boite(0) <> "") Then sDestination = Boite(0) Else 'Destinataire par défaut sDestination = "Mon.Adresse@monserveur.net" End If If (UBound(Boite) > 1) Then If (Boite(1) <> "") Then msgTitre = Boite(1) Else msgTitre = "Automatisme" End If If (UBound(Boite) > 2) Then If (Boite(2) <> "") Then msgTexte = Boite(2) Else msgTexte = "Automatisme" End If If (UBound(Boite) > 3) Then If (Boite(3) <> "") Then sPieceJointe = Boite(5) If (UBound(Boite) > 4) Then Drapeau = Boite(4) End If Else sPieceJointe = "" End If Else sPieceJointe = "" End If Else msgTexte = "Automatisme" sPieceJointe = "" End If Else msgTitre = "Automatisme" msgTexte = "Automatisme" sPieceJointe = "" End If Else MsgBox "Arguments incomplet !" Exit Sub End If With objMail ' Ligne à modifier selon l'adresse de l'envoyeur .From = cteAdresseSource .To = sDestination .Subject = msgTitre ' Ligne à modifier selon le texte voulu ! If (sPieceJointe <> "") Then If (Drapeau = True) Then .TextBody = msgTexte & vbCrLf & LirePieceJointe(sPieceJointe) & vbCrLf Else .TextBody = msgTexte & vbCrLf & "Pièce jointe incluse : " & vbCrLf End If Else .TextBody = msgTexte & vbCrLf & "Aucune Pièce jointe" & vbCrLf End If ' Ligne à modifier selon l'adresse du serveur SMTP .Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "172.27.51.8" .Configuration.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Configuration.Fields.Update If ((sPieceJointe <> "") And (Drapeau = False)) Then .AddAttachment (sPieceJointe) End If .Send End With Set objMail = Nothing End Sub ' Function LirePieceJointe(LeFichier) ' Fonction permettant d'inclure le ' contenu texte d'une pièce jointe Dim objFSO As Object, CeFichier As Object Set objFSO = CreateObject("Scripting.FileSystemObject") If (objFSO.FileExists(LeFichier)) Then Set CeFichier = objFSO.OpenTextFile(LeFichier, cteLecture) LirePieceJointe = CeFichier.ReadAll CeFichier.Close Set CeFichier = Nothing End If Set objFSO = Nothing End Function ' Function Parcourir() As String Dim Chemin As String, NomLong As String, LeFichier As String Dim Position As Integer Dim Drapeau As Boolean Dim Dlg As FileDialog Parcourir = "" Chemin = ThisWorkbook.Path Set Dlg = Application.FileDialog(msoFileDialogOpen) With Dlg .InitialFileName = ThisWorkbook.Path End With If (Dlg.Show <> False) Then Parcourir = Dlg.SelectedItems(1) End If End Function ' Enfin j'ai laissé toute le contenu de mon module, tu devrais y trouver ton bonheur. Cdt Info

Bidouilleu_R · Answer

Sub Send_Mail_Outlook()

'Il faut activer la référence "Microsoft Outlook Library" Avant de lancer cette macro,
' Dans l'éditeur VBA: Faire Menu / Tools / Reference / Cocher "Microsoft Outlook Library"
   Dim ObjOutlook As New Outlook.Application
   Dim ObjOutlookmail As MailItem
   Dim NomFichier As String
   
   Set ObjOutlook = New Outlook.Application
   Set oBjMail = ObjOutlook.CreateItem(olMailItem)
   
   Nom_Fichier = Application.GetOpenFilename("Fichier excel (*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm")
    If Nom_Fichier = "Faux" Then Exit Sub
    If VarType(Nom_Fichier) = vbBoolean Then Exit Sub


   
   
   With oBjMail

        .To = Range("a3").Value
        .To = "prénom.nom@laboitemail.fr"     ' le destinataire
        .Subject = "Ici c'est l'objet"          ' l'objet du mail
        .Body = "Ici le texte Blblblbla "  'le corps du mail ..son contenu
        .Attachments.Add "C:\Data\essai.txt" ' ou Nomfichier
        .Display  '   Ici on peut mettre '.Send' pour l'envoyer sans vérification
   End With
    
    ObjOutlook.Quit
   
End Sub

benzi · Answer

Bonsoir Bidouilleu_R,

J'avais déjà coché "Microsoft Outlook Library" J'ai lancé la macro, il y a un débogage "424" au niveau de :
"Set ObjOutlook = New Outlook.Application"
Je n'arrive toujours pas à une solution.
Merci tout de même de ton aide.

Dan

lermite222 · Answer

Re,   
Essaye avec   
Dim ObjOutlook  As New Application       
Set ObjOutlook  = CreateObject("Outlook.application") Pas tester.   
A+   
EDIT:  
Mais une chose est certaine, c'est qu'il y à double emploi...  
Dim ObjOutlook As New Outlook.Application et ensuite..  
Set ObjOutlook = New Outlook.ApplicationObjOutlook est déjà assigner.  
Toute la connaissance du monde ne peu tenir dans une seul tête  (moi)   
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius)   
NOTE : Je ne répond pas aux MP pour les questions techniques.   
Ça doit se passer sur le forum pour que tous puisse y participer ou en profiter.

Bidouilleu_R · Answer

Bonjour,

j'ai du mal à répondre parce que ... chez moi ça marche.

Ensuite concernant le Dim et le Set ( double emploi)
je croyais qu'il fallait le déclarer ( dim)  puis l'initialiser (set)
j'aurai du plutôt écrire :

Dim ObjOutlook As Object
puis faire 

 Set ObjOutlook = New Outlook.Application

mais dans l'état, ça ne grogne pas chez moi.
je comprends pas .... je vais réviser...

lermite222 · Answer

Re Bidouilleu, 
1°) mettre Option Explicite en haut des modules peu déjà éviter certaine erreurs si cette option est activée par défaut chez le correspondant. 
2°) Oultlok ne fonctionne plus avec Vista, je suppose que tu est avec XP ? 
J'ai essayé le code mis à part les variables non déclarées, je ne suis pas parvenu à faire fonctionner. 
Il faut télécharger un Pack2 de Windows Mail ? mais ça prend 500 Mo.. j'ai pas fait. 
A+ 
Pour que ça fonctionne il faut que Outlook fonctionne en "manuel"

Toute la connaissance du monde ne peu tenir dans une seul tête  (moi) 
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius) 
NOTE : Je ne répond pas aux MP pour les questions techniques. 
Ça doit se passer sur le forum pour que tous puisse y participer ou en profiter.

Bidouilleu_R · Answer

Je te le pique!
et.....
....
Merci

lermite222 · Answer

Bonjour Mike et merci
Ça fait un bon bout de temps que je cherche quelque chose comme ça.
Ne fonctionne pas sur Excel 2000 mais sur Excel 2007 oui.
Très intéressant, une tite question, faut-il avoir un compte chez Free ?
le texte de l'erreur : Client host rejeter : Access denied.

Si oui, comment tu a trouver les adresses http\ pour la configuration.
J'ai un compte Hotmail et Gmail !
A+

benzi · Answer

Bonjour Messieurs,

Tout d'abord merci à tous pour votre implication, mais je ne suis pas sorti d'affaire.
En réponse à Bidouilleu_r et lermite j'ai fait les modif maiss il y a un débogage à ce niveau "Dim ObjOutlookmail As MailItem" Type défini par l'utilisateur non défini...

J'ai fait le code de Mike, je rencontre un autre souci, lorsque je clique pour envoyer cela met l'indice n'appartient pas à la sélection.

Le 1er code que j'ai donné, fontionne avec le corps de message sans la pièce jointe, le second ci-dessous envoi la pièce jointe sans le corps du message:
N'y a t'il pas un moyen de faire un mélange des deux?

Sub EnvoiMail()
Dim i As Workbook
Set i = ActiveWorkbook
Dim Destinataire As String
Dim Texte As String
i.SendMail Recipients:=Range("G87").Value, Subject:="P1 du 5974", ReturnReceipt:=True
Bcc = Range("G91")

'Crée le corps du message avec insertion de sauts de ligne
    Texte = "Bonjour Olivier" & vbCrLf & vbCrLf _
                    & "Veuillez trouvez ci-joint le P1" & Range("C94").Value & vbCrLf & vbCrLf _
                    & "Cordialement " & vbCrLf _
                    & "Prénom Nom " & vbCrLf _
                    & "Grade" & vbCrLf & vbCrLf _
                    & "Les Floralies  " & vbCrLf _
                    & Range("G94").Value & vbCrLf _
                    & Range("G95").Value & vbCrLf _
                    & Range("G96").Value & vbCrLf & vbCrLf _
                    & Range("G87").Value & vbCrLf _

Range("B9").Select

End Sub

Cordialement
Dan

lermite222 · Answer

N'en déplaise à Mike et Bidouilleu... vous ne mettez pas Option Explicit et il manque des déclarations de variables dans les 2 exemples.
En ce qui me concerne, pas de problème je comprend de suite, mais pour des débutants...
A+

Mike-31 · Answer

Re, 

L'option explicit n'est pas nécessaire, mais à chacun ces habitudes 
la déclaration Explicit oblige plus de rigueur et la déclaration de toutes les variables ne laissant pas à Excel la possibilité d'interpréter ou d'adapter un code et conduit très souvent à des blocages. 

Petite expérience 
Utiliser le code comme je l'ai donné, il fonctionne sans problème 
Ajouter en en tête de module Option Explicit, et activer le code il plante à cette ligne 
objMessage 

on ajoute une variable en début de procédure Dim objMessage et on active le code, il replante à cette ligne piece_jointe, ajoutons une autre variable 
Dim piece_jointe 
et le code fonctionne parfaitement 

Suivant les habitudes de chacun,  soit on utilise le code tel que je l'ai donné 
soit on ajoute en en tête de module Option Explicit  
et en début de procédure  
Dim objMessage  
Dim piece_jointe 

Encore mieux préciser le type

Dim objMessage  As Variant
Dim piece_jointe As Variant

A+ 
Mike-31 

Une période d'échec est un moment rêvé pour semer les graines du savoir.

lermite222 · Answer

Re Mike. 
Désolé de te contredire mais je ne peu pas laisser passer ça, essaye un peu, (sans Option Explicit) et imagine l'exemple dans un contexte beaucoup plus compliquer. 
Module 1 
Sub Test() 
    Nb = Nb + 1 
   Call Reporter 
   Debug.Print G 
End Sub

Module 2 
Sub Reporter() 
   If NB > 0 Then R = "J'ai Trouvé !!" : Exit Sub 
    R = "Je passe à côté !!!!" 
End Sub
Aucune erreur, mais quand au fonctionnement, ont peu quelque fois chercher longtemps 
Autre ? 
Laisser Excel choisir ?? 
Sub main() 
     Set F1 = CreateObject("CDO.Message")  
    '...... quelque lignes de code.plus bas 
    F1=12 
'..... 
Jusqu'ici pas d'erreur. 
Par contre là une erreur, évidemment ici, avec quelque ligne c'est pas difficile à voir mais qu'en sera-t-il dans une fonction plus complexe !. 
        F1.Subject = "Sujet du Message"  
End sub 

Conclusion : 
.L'option explicit n'est pas nécessaire d'accord, mais elle est indispensable si ont veux éviter ce genre de perte de temps d'autant plus que les éventuelles erreurs détectées n'auront rien à voir avec la cause de l'erreur.
Cordialement. 
Toute la connaissance du monde ne peu tenir dans une seul tête  (moi) 
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius) 
NOTE : Je ne répond pas aux MP pour les questions techniques. 
Ça doit se passer sur le forum pour que tous puisse y participer ou en profiter.

benzi · Answer

Bonjour à tous, 

J'ai été au début de la demande d'aide et je suis content que mon sujet porte attention et discution car c'est vrai c'est comme cela que l'on avance mais je reste toujours avec ce problème. 
J'ai donné deux exemples qui fonctionnent en parti et lermite a dit qu'il manquait des variables pour les deux codes, je suis débutants dans ce domaine et surtout j'ai envi de comprendre et réussir grace aux connaisseurs. Je ne me suis pas endormi sur mes lauriers, j'ai essayé tous les codes que vous m'avez donné, il y a des débogages et là je bloque. Si les codes que j'ai soumis peuvent fonctionner, se serait bien un peut d'aide de votre part.  
Merci pour votre implication. 
Dan

benzi · Answer

Mike, 

J'ai essayé les codes proposés et comme j'ai expliqué plus en haut j'ai un souci pour les adapter ou il y a un débogage, c'est pour cela que j'ai relancé le forum. 
N'y a t'il pas quelque chose à faire par rapport aux 2 codes que j'ai donné, pourquoi ils fonctionnent bien mais à moitié, un avec le corps de message sans la pièce jointe et l'autre fait l'inverse. C'est surement simple mais ça m'échappe. 

Cordialement 
Dan

Mike-31 · Answer

Re,

Excuse, j'avais zappé ton post, colle ce code dans un module remplace SMTP.FREE.FR (en gras dans le code par ton smtp), en G72 ton adresse mail et teste le, l'avantage de ce code est qu'il n'utilise pas de messagerie

Option Explicit

Sub Mail()
Dim messageHTML As Variant
Dim objMessage As Variant
On Error GoTo errorHandler
Set objMessage = CreateObject("CDO.Message")

objMessage.Subject = "P1 du " & Range("H4").Value
objMessage.From = "xxx.xxxxxx@free.fr" 'adresse mail de l'expéditeur n'est pas obligatoire
objMessage.To = Range("G72").Value 'Email du destinataire doit-être correct ici
'Crée le corps du message avec insertion de sauts de ligne
objMessage.TextBody = "Bonjour Olivier" & vbCrLf & vbCrLf _
& "Veuillez trouvez ci-joint le P1" & Range("C74").Value & vbCrLf & vbCrLf _
& "Cordialement " & vbCrLf _
& "Prénom Nom " & vbCrLf _
& "Grade" & vbCrLf & vbCrLf _
& "Etablissement " & vbCrLf _
& Range("G74").Value & vbCrLf _
& Range("G75").Value & vbCrLf _
& Range("G76").Value & vbCrLf & vbCrLf _
& Range("G68").Value

objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr" 'remplacer ici le smtp par celui de son fournisseur d'accés
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
MsgBox "Le mail a été bien envoyé !" ', 64, "Information"
'si erreur on sort de la procédure
Exit Sub
errorHandler:
'description de l'erreur survenue
MsgBox Err.Description
End Sub

benzi · Answer

Bonjour Mike,

Merci pour ce code, il fonctionne très bien et mieux sans outlook. Le seul souci c'est qu'il n'y a pas la pièce jointe. C'est la mon problème, tout est bien là ou il faut, il y une bonne réception du mail sauf le fichier en pièce jointe.
J'ai essayé une combinaison avec ton code et celui que j'ai posté plus haut le 09 mars (avec lui le fichier est joint sans le message) mais cela ne fonctionne pas. 
Je bloque toujours mais je ne désespère pas.

A+
Dan

benzi · Answer

Re,

Le fichier doit être envoyé à une personne mais pourquoi pas inclure la possibilité de multiples destinataires.
Les adresses mails sont prévues dans les cellules G66, G68, G70, G72.
Les infos dans les cellules C64 - C72 et E64 - E72 c'est le nom et prénom des destinataires avec en face leur mail mais j'ai fait ça pour mémoire, je n'allais pas les laisser que les mails.
Par contre tout ce qui se trouve dans "de la Mecs, Cordialement etc..." c'est ce qui va être le corps du mail, ce qui représente ça:

(objMessage.TextBody = "Bonjour Olivier" & vbCrLf & vbCrLf _ 
& "Veuillez trouvez ci-joint le P1" & Range("C74").Value & vbCrLf & vbCrLf _ 
& "Cordialement " & vbCrLf _     
& "Prénom Nom " & vbCrLf _ 
& "Grade" & vbCrLf & vbCrLf _ 
& "Etablissement " & vbCrLf _ 
& Range("G74").Value & vbCrLf _ 
& Range("G75").Value & vbCrLf _ 
& Range("G76").Value & vbCrLf & vbCrLf _ 
& Range("G68").Value)

Dans les cellules G74 à G76 c'est l'adresse du site et le tél.
C'est vrai que ces infos seraient envoyées avec le fichier joint, je comptais après mettre la couleur de police en blanc afin que cela ne se voit pas. Mais on peut mettre ces infos dans le code en effet par plus de sécurité.

Je ne savais pas que l'on pouvait masquer les boutons mais je suis d'accord.

Le code que tu as fais plus est est très bien, tu as bien repris tout ce qui était dans les cellules, ce qui reste c'est de joindre le fichier.

Si tu as besoin, je peux t'envoyer le fichier avec la macro, c'est faisable jusquà 8MO.

A+
Dan

benzi · Answer

Bonsoir Mike,

Tout d'abord un très très grand merci pour ton aide car cela fonctionne à merveille. Cela faisait longtemps que je cherchais ce code.
J'ai suivi ton conseil au sujet des infos dans les cellules, pour ce faire j'ai fait quelques modifs, ces données sont effacées lors de l'envoi, j'ai ajouté des infos bulles pour que chaques collaborateurs qui utilisent ce planning, puissent mettre dans les cellules appropriées leurs propres adresses mail et coordonnées.
Je garde au chaud le code qui masque les boutons, c'est intéressant mais pour ce fichier ce n'est pas l'idéal car il y a des formules et d'autres macros notament avec l'image (je l'avais enlevé) et cela élimine tout. 
Est-ce que c'est faisable de créer un commandbutton, y affecter l'envoi et de masquer que le bouton, laissant les images et formules?
Je te joint le fichier complet afin que tu te donnes une idée.
http://www.cijoint.fr/cjlink.php?file=cj201103/cijyoPe3V5.xls

A +
Dan

benzi · Answer

Bonsoir Mike,  

Je souhaite envoyer la feuille complète avec les données en bas du tableau, j'ai fait des modifs qui effacent que les valeurs dans les cellules en jaunes.   
Il y a un code associé à l'image qui en effet efface toutes les données, cela fonctionne sans problème.  
Le Userform me sert à entrée des données dans les cellules bleues. Lorsque tu te positionnes sur une cellule, tu tapes "Entrée" , tu as une liste qui apparait, dans cette liste figure les "présences, repos, CP etc..." tu choisis ce qui te concerne et ensuite tu tapes de nouveau "entrée" et tu as la lettre correspondante à "Présent" càd "P" "Repos" : "RH" ainsi de suite.  
La liste déroulante des jours servent à déterminer les jours, on le positionne sur 1 er jour du mois, là le 1 janvier commençait un samedi.  
Idem sur la ligne "Théorique" pour les "P" et "R" le samedi et un jour de repos donc il y a "R"  
Liste déroulante des mois, logique sert à choisir chaque mois et sur les lignes couleur saumon il y a une liste déroulante avec des chiffres en positifs et négatifs, eux servent à calculer heures sup ou retard en fin de mois. D'où besoin de garder les formules.  
Je serai intéresser de pouvoir enlever que le bouton, cela me permettrer d'appliquer le code à un autre fichier que j'ai créé où la personne qui le reçoit n'a pas besoin de voir les boutons ou formes.  

Je te renvoi le fichier sans mot de passe.  
http://www.cijoint.fr/cjlink.php?file=cj201103/cijQfAOjOe.xls  

A+  
Dan

benzi · Answer

Bonsoir Mike,

Cela fonctionne très bien, c'est un super travail. Je te remercie beaucoup du coup de main et de ton implication.
Je vais d'ailleurs créer un nouveau post en donnant les explications et toutes les fonctionnalités du code car il y a eu plus de choses ajoutées par rapport à la demande initiale et cela pourrait aider du monde.

Une seule et dernière demande supplémentaire, à ce code peut-on ajouter une formule qui permet d'envoyer une seule feuille d'un classeur?
J'ai adapté le code à un fichier qui comporte plusieurs feuilles et je voudrai envoyer qu'une feuille.

Merci
A+
Dan

benzi · Answer

Bonsoir Mike,

Il y a 6 feuilles.
La 1 se nomme : Présentation 
La 2 : Fiche technique
La 3 : Récap
La 4 : Menu
La 5 : Devis
La 6 : Facture

Il y aurait à expédier la 5 càd "Devis"
Par la suite j'essairai tout seul de faire la même chose avec "Facture"

Si tu veux plus de détails, dans la feuille 1 et 5 il y a un userform, dans chaque feuille des images (comme dans le planning) qui me permettent de revenir à la feuille "présentation" ainsi que d'autres formes.
Si tu as besoins d'autres infos, je te les donnent.

C'est le code que tu m'as donné et que j'utilise pour envoyer la feuille pour l'instant mais il ne supprime pas les formes et objets

Option Explicit

Sub EnvoiMail()
Application.DisplayAlerts = False   'Supprime l'alerte Enregistrer
Dim objMessage As Variant
Dim nom As String
 
'ici on cré le chemin complet de ton fichier qui sera créé plus bas
nom = ActiveWorkbook.Path & "\Devis.xls"
 
'on crée le fichier et on le sauve avec le nom créé juste avant
'Copie la feuille dans le fichier à envoyer
ThisWorkbook.ActiveSheet.Copy       '
'Supprime les controls ou tout activx

 'Enregistre le fichier à envoyer davec le nom que l'on a cré plus haut
ActiveWorkbook.SaveAs nom
'Ferme le fichier
ActiveWorkbook.Close
 
On Error GoTo errorHandler
'on cré une instance de la reference "cdo" (message)
Set objMessage = CreateObject("CDO.Message")
 
'avec le message blablabla  blablabla
 With objMessage
.Subject = "Devis du " & Range("B13").Value
.From = Worksheets("Présentation").Range("K52").Value  'adresse mail de l'expéditeur n'est pas obligatoire
.To = Worksheets("Présentation").Range("K54").Value 'Email du destinataire doit-être correct ici
.Cci = Worksheets("Présentation").Range("K56").Value    'Email du destinataire en copie
 
'Crée le corps du message avec insertion de sauts de ligne
.TextBody = "Bonjour" & " " & Worksheets("Présentation").Range("C62").Value & "," & vbCrLf & vbCrLf _
& "Veuillez trouvez ci-joint le devis du " & Range("D10").Value & "." & vbCrLf & vbCrLf _
& "Cordialement " & vbCrLf _
& Worksheets("Présentation").Range("C66").Value & vbCrLf _
& Worksheets("Présentation").Range("C67").Value & vbCrLf & vbCrLf _
& Worksheets("Présentation").Range("C64").Value & vbCrLf _
& Worksheets("Présentation").Range("K61").Value & vbCrLf _
& Worksheets("Présentation").Range("K62").Value & vbCrLf _
& Worksheets("Présentation").Range("K63").Value & vbCrLf _
& Worksheets("Présentation").Range("K64").Value & vbCrLf & vbCrLf _
& Worksheets("Présentation").Range("K52").Value
        
  
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr"  'remplacer ici le smtp par celui de son fournisseur d'accés
.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Configuration.Fields.Update
.AddAttachment (nom)
.Send

Dim Reponse
Reponse = MsgBox("Etes-sûr de vouloir effacer les coordonnées dans la feuille Préentation ? ", vbInformation + vbYesNo)
If Reponse = vbYes Then
Worksheets("Présentation").Range("K52:K56").Value = ""  'Efface les données dans la feuille Présentation dans les cellules K52 à K56
Worksheets("Présentation").Range("K61:K64").Value = ""  ' K61 à K64
Worksheets("Présentation").Range("C62:C67").Value = ""  ' C62 à C67
End If

MsgBox "Le mail a été bien envoyé !" 'Confirmation de l'envoi
        'après l'envoi le fichier créé est supprimé
Kill ActiveWorkbook.Path & "\" & "Devis.xls"
        'si erreur on sort de la procédure
Exit Sub
errorHandler:
        'description de l'erreur survenue
MsgBox Err.Description
End With
End Sub

A+
Dan

Mike-31 · Answer

Re,

dans le code tu trouveras ce bout de code qui prévoit de supprimer toutes les feuilles d'un classeur sauf les feuilles nommées Devis, xx et xxxx

For Each x In Worksheets
If x.Name <> "Devis" And x.Name <> "XX" And x.Name <> "XXXX" Then x.Delete
Next

pour conserver que la feuille Devis tu peux écrire simplement cette ligne
If x.Name <> "Devis" Then x.Delete

le code complet

Sub Envoi_Mail()
'-------------------------------------------------------Création du nom du fichier d'envoi
[A2] = "Planning " & Format(Range("C9").Value, "mmm yy") & ".xls"
Dim chemin, nom, renom As String
Dim x As Worksheet
chemin = ActiveWorkbook.Path
nom = [A2]
renom = "Planning"
'--------------------------------------------------Création du fichier d'envoi
Application.DisplayAlerts = False '------------------Annulation des alertes
ActiveWorkbook.Save
ActiveWorkbook.SaveAs Filename:=chemin & "\" & nom
'--------------------------------------------------Retour sur le fichier initial
ActiveWorkbook.SaveAs Filename:=chemin & "\" & renom
Workbooks.Open Filename:=chemin & "\" & nom
ActiveSheet.Shapes("Rectangle 80").Visible = False 'Masquer le bouton d'envoi
Range("A2:B2,K52:N52,K54:N54,K56:N56").ClearContents 'Supprimer adresses mail sur le fichier à envoyer
'--------------------------------------------------Supprimer éventuellement la feuille nommée "Feuil1"
For Each x In Worksheets
If x.Name <> "Devis" And x.Name <> "XX" And x.Name <> "XXXX" Then x.Delete
Next
'--------------------------------------------------Enregistrement et fermeture du classeur à expédier
ActiveWorkbook.Save
ActiveWorkbook.Close
'--------------------------------------------------Appel de la procédure d'envoi
Call Procédure_Envoi
'--------------------------------------------------Suppression du fichier après envoi
Kill ActiveWorkbook.Path & "\" & [A2].Value
'--------------------------------------------------Effacement des cellules de création du nom du fichier envoyé
[A2:B2].ClearContents
ActiveWorkbook.Save
Application.DisplayAlerts = True '------------------rétablissement des alertes
End Sub

Sub Procédure_Envoi()
Dim messageHTML As Variant
Dim objMessage As Variant
Dim piece_jointe As Variant
'--------------------------------------------------crée le fichier à envoyer
On Error GoTo errorHandler
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "P1 du " & Range("H4").Value
objMessage.From = Range("K52").Value '---------------adresse mail de l'expéditeur n'est pas obligatoire
objMessage.To = Range("K54").Value '---------------Email du destinataire doit-être correct ici
objMessage.Cc = Range("K56").Value '---------------Email du destinataire en copie
'-------------------------------------------------Création le corps du message avec insertion de sauts de ligne
objMessage.TextBody = "Bonjour" & " " & Range("C62").Value & "," & vbCrLf & vbCrLf _
& "Veuillez trouvez ci-joint le P1 " & Range("C64").Value & "." & vbCrLf & vbCrLf _
& "Cordialement " & vbCrLf _
& Range("C66").Value & vbCrLf _
& Range("C67").Value & vbCrLf & vbCrLf _
& Range("C64").Value & vbCrLf _
& Range("K61").Value & vbCrLf _
& Range("K62").Value & vbCrLf _
& Range("K63").Value & vbCrLf _
& Range("K64").Value & vbCrLf & vbCrLf _
& Range("K52").Value
'-------------------------------------------------Sélectionnes la pièce à joindre
piece_jointe = ActiveWorkbook.Path & "\" & [A2].Value '"Planning janv 11.xls" '"Planning.xls"
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.free.fr" 'remplacer ici le smtp par celui de son fournisseur d'accés
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.AddAttachment (piece_jointe)
objMessage.Send
MsgBox "Le mail a été bien envoyé !" '---------------Confirmation de l'envoi
'------------------------------------------------Si erreur on sort de la procédure
Exit Sub
errorHandler:
'------------------------------------------------Description de l'erreur survenue
MsgBox Err.Description
End Sub

et le lien du fichier

https://www.cjoint.com/?ADmvnyiUoc8
A+
Mike-31

Une période d'échec est un moment rêvé pour semer les graines du savoir.

Envoi mail en vba avec corps message - Page 2

Discussions similaires

Newsletters