Envoi de mail avec plage dans le corps
Bonjour à tous!
Je reviens sur ce forum car j'ai repris un élément de macro sur lequel je bossais il y a quelques temps afin de l'appliquer à mon nouveau projet.
Le souci que je rencontre est dans la dernière partie de mon code :
L'envoi de mail automatique via Outlook.
Il s'agit de quelque chose que je sais faire et que j'ai déjà appliqué à différents sujets, mais là, le cumul de différents critères fait que je n'arrive pas à en voir le bout.
Je m'explique.
Je cherche à envoyer un mail automatiquement à un fournisseur (que j'irai chercher dans une cellule) qui contiendrait dans le corps du texte, deux plages de cellules variables en nombre de lignes ainsi que ma signature par défaut.
Thev m'avait aidé dans le précédent sujet en me donnant l'astuce du rng qui me permet de copier coller la plage dans le mail après ouverture de celui-ci.
Il restait cependant un problème. Avec cette astuce, je perds la possibilité de changer l'adresse mail émettrice.
Je crois avoir essayé tout ce que je pouvais pour la changer, mais impossible. J'ai dans mon entreprise une boîte personnelle et une boîte générique utilisé par mes collègues et moi-même. Le but étant ici d'envoyer le mail à partir de la boîte générique afin que les réponses des fournisseurs arrivent dessus et pas sur la boîte perso de la personne qui utilisera la macro.
Quelqu'un aurait-il une astuce? Le mail actuel est parfait, je n'ai plus qu'à ajouter quelques variables et de la mise en forme mais ce que j'ai actuellement me convient parfaitement. Le seul souci est cette adresse mail.
Voici mon code (censuré bien sûr) :
Sub SendMail()
' Déclarer des variables
Dim PlageFeuilleComp As Range
Dim PlageFeuillePart As Range
Dim DerLigMailComp As Long
Dim DerColMailComp As Long
Dim DerLigMailPart As Long
Dim DerColMailPart As Long
Dim DerLigDest As Long
' Définition des variables
Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
'// assignation application Outlook
Set OL = CreateObject("Outlook.Application")
DerLigMailComp = Workbooks("Transit.xlsx").Sheets("Complètes").Cells(Rows.Count, 1).End(xlUp).Row
DerColMailComp = Workbooks("Transit.xlsx").Sheets("Complètes").Cells(1, Columns.Count).End(xlToLeft).Column
DerLigMailPart = Workbooks("Transit.xlsx").Sheets("Partielles").Cells(Rows.Count, 1).End(xlUp).Row
DerColMailPart = Workbooks("Transit.xlsx").Sheets("Partielles").Cells(1, Columns.Count).End(xlToLeft).Column
' plage feuille à envoyer
Set PlageFeuilleComp = Workbooks("Transit.xlsx").Sheets("Complètes").Range(Cells(1, 1).Address, Cells(DerLigMailComp, 11).Address)
Set PlageFeuillePart = Workbooks("Transit.xlsx").Sheets("Partielles").Range(Cells(1, 1).Address, Cells(DerLigMailPart, 11).Address)
' Assignation des objets
Set myItem = OL.CreateItem(olMailItem): Set wDoc = myItem.GetInspector.WordEditor
' Création Email et envoi
With myItem
' Expéditeur, Destinataire, Sujet
.SentOnBehalfOfName = "monmailgénérique@entreprise.fr" 'Adresse qui doit remplacer mon adresse perso
.To = Workbooks("Transit.xlsx").Sheets("Complètes").Cells(2, 10).Value 'A adapter de façon à ce que ça fonctionne avec complète ou partielle
.Subject = "Relance AR du " & Date & " " & Workbooks("Transit.xlsx").Sheets("Complètes").Cells(2, 4).Value 'A adapter de façon à ce que ça fonctionne avec complète ou partielle
.Display
Set rng = wDoc.Content
' Corps du mail
rng.InsertParagraphBefore
rng.Move 4, -1
rng.InsertAfter "Bonjour," & vbNewLine
rng.InsertAfter vbNewLine & "Nous vous invitons à trouver ci-dessous les commandes pour lesquelles nous attendons une confirmation d'un ou plusieurs postes." & vbNewLine
rng.InsertAfter vbNewLine & "Dans l'attente d'une réponse de votre part dans les meilleurs délais, vous avez la possibilité de nous signaler une anomalie à l'aide de la case commentaire (attention, cette case ne fait pas acte d'AR)." & vbNewLine
rng.InsertAfter vbNewLine & "Commandes complètes :" & vbNewLine
' Copie de la plage
rng.InsertParagraphAfter
rng.Move 4, 1
PlageFeuilleComp.Copy
rng.Paste
rng.Move 4
rng.InsertAfter vbNewLine & "Commandes partielles :" & vbNewLine
' Copie de la plage
rng.InsertParagraphAfter
rng.Move 4, 1
PlageFeuillePart.Copy
rng.Paste
rng.Move 4
rng.InsertAfter vbNewLine & vbNewLine & "Si vous n'êtes pas concerné par ce message, merci de nous le signaler et de nous transmettre les coordonnées de la personne qui gère cette activité." & vbNewLine
rng.InsertAfter vbNewLine & "Restant à votre disposition pour toute information complémentaire,"
' Police du corps du mail
With rng.Font
.Name = "Helvetica"
.Size = 11
.Color = 10050863
End With
' Envoi
'.Send
End With
' désassignation des objets
Set myItem = Nothing: Set wDoc = Nothing
'// désassignation application Outlook
Set OL = Nothing
End SubCe que je veux faire mais qui ne fonctionne pas, c'est le "SentOnBehalfOfName...".
Ne faites pas attention si le code n'est pas opti, c'est encore une ébauche et quelques variables sont inutiles (je pense à mes DerCol notamment) et je ferai les vérifications lorsque j'aurai un code qui fonctionne à 100%.
Merci d'avance pour votre aide!
Bonjour,
as-tu (tu=le compte avec lequel ta macro se connecte à outlook) les autorisations pour envoyer par délégation avec l'identifiant de cette boite mail partagée ?
Bonjour h2so4!
Pas de souci de ce côté-là.
Je suis admin sur la boîte partagée et plusieurs de mes codes permettant d'envoyer des mails automatiquement fonctionnent parfaitement.
Celui-là par exemple :
Sub SendMail()
'Mail auto avec boucle jusqu'à ce que A2 soit vide
Sheets("ZE2N").Select
Do
Dim OutApp As Object
Dim OutMail As Object
Dim Corps As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Votre demande" & "<span style=""color:#E23232"">" & Range("B2").Offset(0, 2).Value & "</span>" & " a bien été prise en compte par notre service le " & "<span style=""color:#E23232"">" & Range("B2").Offset(0, 4).Value & "</span>" & ".<br/><br/>" & "Elle est enregistrée sous le numéro de commande " & "<span style=""color:#E23232"">" & Range("B2").Offset(0, -1).Value & "</span>" & " (plusieurs commandes peuvent être rattachées à une même demande).<br/><br/>" & "Le fournisseur retenu pour cette commande est : " & "<span style=""color:#E23232"">" & Range("B2").Offset(0, 1).Value & "</span>" & ".<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "mailgénérique@entreprise.fr"
.To = Range("B2").Value
.Display
.BCC = "mailosef@entreprise.fr"
.Subject = "Confirmation de prise en compte de la demande " & Range("B2").Offset(0, 2).Value
.HTMLBody = Corps & .HTMLBody
.Send
End With
On Error GoTo Oups
Set OutMail = Nothing
Set OutApp = Nothing
Oups: Resume Next
Range("2:2").Delete
Loop While Range("A2") <> ""
Call Réinitialiser
MsgBox ("Les confirmations de commandes ont été envoyées avec succès.")
End SubSeul ce code ne veut pas...
Bonjour,
Je reviens finalement vers vous car j'ai trouvé solution à mon problème...
En fait, il n'y avait aucun problème!
Il s'avère que j'avais simplement pris trop de précautions en faisant mon code et en me rendant compte que le .display de mon mail m'affichait un mail avec le mauvais expéditeur je m'étais bloqué là-dessus en me disant qu'il y avait un souci.
Aujourd'hui, n'ayant toujours pas trouvé de solutions, j'ai simplement essayé de modifier les mails dans mon exemple par des fictifs (le mien et celui de mes collègues) et j'ai enlevé l'apostrophe de mon '.send afin de le rendre fonctionnel, chose que je n'osais pas faire car trop focalisé sur l'expéditeur qui n'était pas bon en display.
Et puis voilà, que dire... ça fonctionne...
Il s'avère donc que l'action de changement d'expéditeur se fait à l'envoi et non à l'affichage!
Bref, merci à tous ceux qui ont pu m'aider jusqu'à maintenant, le problème est résolu!
A bientôt
Bonjour,
merci de ton retour.