Envoi de plage de cellule dans un mail
Bonjour à tous,
J'ai besoin d'aide :'(.
Je travaille actuellement sur une refonte complète d'un de mes outils, et j'avais pour ambition un envoi de mail automatisé afin de relancer des fournisseurs.
Je ne peux malheureusement pas mettre en PJ le fichier par souci de confidentialité, mais je vais insérer un bout de code :
Sub Tri()
' Déclarer des variables
Dim Critere As String
Dim RSource As Range
Dim RDest As Range
Dim RTitres As Range
Dim RColonneUtilisateur As Range
Dim i As Long
Dim DerLig As Long
Dim DerCol As Long
Dim DerLigDest As Long
Dim IndiceColonne As Long
Dim Feuilles As Worksheet
' On supprime les feuilles inutiles
SuppressionFeuilles
' On va affecter des valeurs par défaut
DerLig = Sheets("Suivi").Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Sheets("Suivi").Cells(1, Columns.Count).End(xlToLeft).Column
' On affecte les titres pour pouvoir les copier dans les feuilles créées
Set RTitres = Sheets("Suivi").Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
Set RColonneUtilisateur = RTitres.Find("Mail", LookIn:=xlValues)
IndiceColonne = RColonneUtilisateur.Column
' Désactiver l'affichage à l'écran
Application.ScreenUpdating = False
' On trie selon la colonne choisie
Sheets("Suivi").Sort.SortFields.Clear
Sheets("Suivi").Sort.SortFields.Add Key:=RColonneUtilisateur, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Suivi").Sort
.SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' On parcourt les lignes
For i = 2 To DerLig
' On récupère le Critere de la ligne
Critere = Left(Sheets("Suivi").Cells(i, IndiceColonne).Value, 10)
If Critere <> "" Then
' On va vérifier si la feuille existe
' Si elle n'existe pas
If VerifFeuille(Critere) = False Then
' On créé la feuille en dernier
Sheets.Add after:=Sheets(Sheets.Count)
' On la nomme
Sheets(Sheets.Count).Name = Critere
' On copie les titres
Set RDest = Sheets(Critere).Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
RDest.Value = RTitres.Value
' Mise en forme
With RDest
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
End With
End If
' On cherche la ligne où l'on doit copier dans la feuille de destination
DerLigDest = Sheets(Critere).Cells(Rows.Count, 1).End(xlUp).Row + 1
' On déclare le range source de la ligne à copier
Set RSource = Sheets("Suivi").Range(Cells(i, 1).Address, Cells(i, DerCol).Address)
' On déclare le range où il faut copier la source
Set RDest = Sheets(Critere).Range(Cells(DerLigDest, 1).Address, Cells(DerLigDest, DerCol).Address)
' On copie la ligne
RDest.Value = RSource.Value
End If
Next i
' Pour chaque feuille dans la collection des feuilles
For Each Feuilles In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then
' On prend les colonnes du range des titres et on met leur taille en autofit
Feuilles.Range(Cells(1, 1).Address, Cells(1, DerCol).Address).Columns.EntireColumn.AutoFit
End If
Next
' On se remet sur la feuille du début
Sheets("Suivi").Activate
' On remet le tri d'origine
Sheets("Suivi").Sort.SortFields.Clear
Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(DerLig, 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(DerLig, 2)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Suivi").Sort
.SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
' Pour chaque feuille dans la collection des feuilles
For Each Feuilles In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then
DerLig = Feuilles.Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Feuilles.Cells(1, Columns.Count).End(xlToLeft).Column
' Envoi de mails
Dim OutApp As Object
Dim OutMail As Object
Dim Corps As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
' Corps du mail
Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous :<br/><br/>" & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"
On Error Resume Next
With OutMail
' Expéditeur
.SentOnBehalfOfName = "monmail@mail.fr"
.To = Feuilles.Cells(2, 12).Value
.Display
' En copie
'.BCC =
' Objet du mail
.Subject = "Relance " & Feuilles.Cells(2, 19).Value
.HTMLBody = Corps & .HTMLBody
' Envoi du mail, ajouter une apostrophe avant pour le désactiver
'.Send
End With
On Error GoTo Oups
Set OutMail = Nothing
Set OutApp = Nothing
Oups: Resume Next
End If
Next
End Sub
Ce bout de code me permet de créer une feuille par mail à relancer, puis à envoyer un mail pour chaque feuille aux personnes correspondantes.
Mon souci est que je n'arrive pas à intégrer le contenu de ma feuille (que ce soit sous forme de plage de cellules, de feuille ou je ne sais quoi) et que dans l'idéal il faudrait soit la plage directement dans le mail ou en PJ, de sorte que le fournisseur puisse ajouter ses commentaires dans celle-ci.
J'avais espéré créer une variable range en utilisant DerLig et DerCol en Range(Cells(1,1).Address,Cells(DerLig,DerCol).Address) et intégrer cette variable directement dans le corps mais ça ne fonctionne pas...
Quelqu'un aurait une solution?
Merci d'avance!
Bonjour,
Utilise la balise code </> car là ce n'est pas trop lisible.
Une solution est d'utiliser sendkeys
Range("A:A").Copy
email.display
Application.Wait (Now + TimeValue("0:00:01"))
SendKeys "^v", True
Application.CutCopyMode = False
Désolé! Je ferai ça la prochaine fois
Pas mal ça! Je vais essayer et je reviens donner le résultat!
Merci pour ton aide!
Pour simplifier, je mets aussi le laïus (Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous :) dans la feuille excel et je copie le tout comme l'exemple !
- Messages
- 4'088
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonjour,
ci-dessous un code permettant d'afficher une plage de cellules sous le corps du message
Sub Envoi_Mail()
' Définition des variables
Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
Dim feuille As Worksheet, plage_feuille As Range
'// assignation application Outlook
Set OL = CreateObject("Outlook.Application")
'// Pour chaque feuille dans la collection des feuilles
For Each feuille In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If feuille.Name <> "Menu" And feuille.Name <> "Suivi" And feuille.Name <> "Annuaire" Then
With feuille
' Corps du mail
Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passées chez vous :<br/><br/>" & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"
' plage feuille à envoyer
Set plage_feuille = .Range("A1:I20")
' Assignation des objets
Set myItem = OL.CreateItem(olMailItem): Set wDoc = myItem.GetInspector.WordEditor
' Création Email et envoi
With myItem
' Expéditeur, Destinataire, Sujet, Corps
.SentOnBehalfOfName = "xxxxxxxxx@domaine.fr"
.To = feuille.Cells(2, "L").Value
.Subject = "Relance " & feuille.Cells(2, "S").Value
.HTMLBody = Corps
.Display
' Copie de la plage
plage_feuille.Copy
Set rng = wDoc.Content
rng.InsertParagraphAfter
rng.Move 4, 1
rng.Paste
rng.Move 4
' Envoi
.Send
End With
' désassignation des objets
Set myItem = Nothing: Set wDoc = Nothing
End With
End If
Next feuille
'// désassignation application Outlook
Set OL = Nothing
End Sub
Bonjour thev,
En utilisant ta méthode, je suis arrivé à quelque chose d'assez satisfaisant!
Voici mon bout de code modifié avec tes éléments :
Sub testmail()
' Déclarer des variables
Dim Critere As String
Dim RSource As Range
Dim RDest As Range
Dim RTitres As Range
Dim RColonneUtilisateur As Range
Dim PlageEnvoi As Range
Dim i As Long
Dim DerLig As Long
Dim DerCol As Long
Dim DerLigDest As Long
Dim IndiceColonne As Long
Dim Feuilles As Worksheet
' On supprime les feuilles inutiles
SuppressionFeuilles
' On va affecter des valeurs par défaut
DerLig = Sheets("Suivi").Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Sheets("Suivi").Cells(1, Columns.Count).End(xlToLeft).Column
' On affecte les titres pour pouvoir les copier dans les feuilles créées
Set RTitres = Sheets("Suivi").Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
Set RColonneUtilisateur = RTitres.Find("Mail", LookIn:=xlValues)
IndiceColonne = RColonneUtilisateur.Column
' Désactiver l'affichage à l'écran
Application.ScreenUpdating = False
' On trie selon la colonne choisie
Sheets("Suivi").Sort.SortFields.Clear
Sheets("Suivi").Sort.SortFields.Add Key:=RColonneUtilisateur, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Suivi").Sort
.SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' On parcourt les lignes
For i = 2 To DerLig
' On récupère le Critere de la ligne
Critere = Left(Sheets("Suivi").Cells(i, IndiceColonne).Value, 10)
If Critere <> "" Then
' On va vérifier si la feuille existe
' Si elle n'existe pas
If VerifFeuille(Critere) = False Then
' On créé la feuille en dernier
Sheets.Add after:=Sheets(Sheets.Count)
' On la nomme
Sheets(Sheets.Count).Name = Critere
' On copie les titres
Set RDest = Sheets(Critere).Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
RDest.Value = RTitres.Value
' Mise en forme
With RDest
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
End With
End If
' On cherche la ligne où l'on doit copier dans la feuille de destination
DerLigDest = Sheets(Critere).Cells(Rows.Count, 1).End(xlUp).Row + 1
' On déclare le range source de la ligne à copier
Set RSource = Sheets("Suivi").Range(Cells(i, 1).Address, Cells(i, DerCol).Address)
' On déclare le range où il faut copier la source
Set RDest = Sheets(Critere).Range(Cells(DerLigDest, 1).Address, Cells(DerLigDest, DerCol).Address)
' On copie la ligne
RDest.Value = RSource.Value
End If
Next i
' Pour chaque feuille dans la collection des feuilles
For Each Feuilles In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then
' On ajoute la colonne Commentaire
Columns(12).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(1, 12).Value = "Commentaire"
' On prend les colonnes du range des titres et on met leur taille en autofit
Feuilles.Range(Cells(1, 1).Address, Cells(1, DerCol + 1).Address).Columns.EntireColumn.AutoFit
End If
Next
' On se remet sur la feuille du début
Sheets("Suivi").Activate
' On remet le tri d'origine
Sheets("Suivi").Sort.SortFields.Clear
Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(DerLig, 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(DerLig, 2)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Suivi").Sort
.SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
' Définition des variables
Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
Dim Feuille As Worksheet, PlageFeuille As Range
'// assignation application Outlook
Set OL = CreateObject("Outlook.Application")
'// Pour chaque feuille dans la collection des feuilles
For Each Feuille In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuille.Name <> "Menu" And Feuille.Name <> "Suivi" And Feuille.Name <> "Annuaire" Then
With Feuille
' Corps du mail
Corps = "<span style=""color:#2F5D99""><font size=3><font face=Helvetica>Bonjour,<br/><br/>" & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous,<br/><br/>" & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.<br/><br/><br/>" & "Restant à votre disposition pour toute information complémentaire,<br/><br/><font/><font/></span>"
DerLig = Feuille.Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Feuille.Cells(1, Columns.Count).End(xlToLeft).Column
' plage feuille à envoyer
Set PlageFeuille = Feuille.Range(Cells(1, 1).Address, Cells(DerLig, 12).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, Corps
.SentOnBehalfOfName = "monmail@mail.fr"
.To = Feuille.Cells(2, 13).Value
.Subject = "Relance " & Feuille.Cells(2, 20).Value
.HTMLBody = Corps & .HTMLBody
.Display
' Copie de la plage
PlageFeuille.Copy
Set rng = wDoc.Content
rng.InsertParagraphAfter
rng.Move 4, 1
rng.Paste
rng.Move 4
' Envoi
'.Send
End With
' désassignation des objets
Set myItem = Nothing: Set wDoc = Nothing
End With
End If
Next Feuille
'// désassignation application Outlook
Set OL = Nothing
End Sub
Ça fonctionne très bien, mon mail s'affiche avec le contenu voulu. Par contre, je n'avais pas précisé que la signature par défaut de l'utilisateur devait s'insérer en fin de mail, d'où le
.HTMLBody = Corps & .HTMLBody.
Le souci maintenant, c'est que forcément, la plage de cellule s'insère en fin de mail, donc après ma signature.
J'aurais voulu qu'elle s'insère entre
etVeuillez trouver ci-dessous les commandes non livrées que nous avons passé chez vous,
Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison.
J'ai essayé de déplacer le HTMLBody après le display ou de le diviser en deux pour avoir d'un côté le format et de l'autre le corps du mail mais ça ne fonctionne pas. J'ai l'impression qu'il faut que le format soit géré avant de display le mail. Et même si j'arrivais à séparer tout ça, j'imagine que la plage ne se mettrait pas non plus où je veux...
En tout cas merci pour l'aide, j'ai déjà bien avancé grâce à vous! Ne me reste plus que le détail du positionnement de ma plage de cellule et l'affaire sera bouclée
Un grand merci!
- Messages
- 4'088
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonjour,
Ce nouveau code devrait résoudre ton problème de signature :
'.....................................................................
' Définition des variables
Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
Dim Feuille As Worksheet, PlageFeuille As Range
'// assignation application Outlook
Set OL = CreateObject("Outlook.Application")
'// Pour chaque feuille dans la collection des feuilles
For Each Feuille In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuille.Name <> "Menu" And Feuille.Name <> "Suivi" And Feuille.Name <> "Annuaire" Then
With Feuille
DerLig = Feuille.Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Feuille.Cells(1, Columns.Count).End(xlToLeft).Column
' plage feuille à envoyer
Set PlageFeuille = Feuille.Range(Cells(1, 1).Address, Cells(DerLig, 12).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 = "monmail@mail.fr"
.To = Feuille.Cells(2, 13).Value
.Subject = "Relance " & Feuille.Cells(2, 20).Value
.Display
Set rng = wDoc.Content
' Corps du mail
rng.InsertParagraphBefore
rng.Move 4, -1
rng.InsertAfter vbNewLine & "Bonjour," & vbNewLine
rng.InsertAfter vbNewLine & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passées chez vous :" & vbNewLine
rng.InsertAfter vbNewLine & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison." & vbNewLine
rng.InsertAfter vbNewLine & "Restant à votre disposition pour toute information complémentaire," & vbNewLine
' Police du corps du mail
With rng.Font
.Name = "Helvetica"
.Size = 12
.Color = 16711680
End With
' Copie de la plage
rng.InsertParagraphAfter
rng.Move 4, 1
PlageFeuille.Copy
rng.Paste
rng.Move 4
' Envoi
.Send
End With
' désassignation des objets
Set myItem = Nothing: Set wDoc = Nothing
End With
End If
Next Feuille
'// désassignation application Outlook
Set OL = Nothing
End Sub
J'avais préconisé SendKeys, mais j'écris aussi parfois en html dans le VBAUne solution est d'utiliser sendkeys
Je dois aussi avoir un module qui crée le html en fonction de la zone (je vais rechercher)
Waouh... Merci thev!
Je viens de faire un test rapide et ça fonctionne!
Je vais modifier tout ça pour faire les finitions et je reviens
Edit : C'est parfait :O. Voici mon code modifié au cas où ça pourrait servir à quelqu'un :
Sub Tri()
' Déclarer des variables
Dim Critere As String
Dim RSource As Range
Dim RDest As Range
Dim RTitres As Range
Dim RColonneUtilisateur As Range
Dim PlageEnvoi As Range
Dim i As Long
Dim DerLig As Long
Dim DerCol As Long
Dim DerLigDest As Long
Dim IndiceColonne As Long
Dim Feuilles As Worksheet
' On supprime les feuilles inutiles
SuppressionFeuilles
' On va affecter des valeurs par défaut
DerLig = Sheets("Suivi").Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Sheets("Suivi").Cells(1, Columns.Count).End(xlToLeft).Column
' On affecte les titres pour pouvoir les copier dans les feuilles créées
Set RTitres = Sheets("Suivi").Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
Set RColonneUtilisateur = RTitres.Find("Mail", LookIn:=xlValues)
IndiceColonne = RColonneUtilisateur.Column
' Désactiver l'affichage à l'écran
Application.ScreenUpdating = False
' On trie selon la colonne choisie
Sheets("Suivi").Sort.SortFields.Clear
Sheets("Suivi").Sort.SortFields.Add Key:=RColonneUtilisateur, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Suivi").Sort
.SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' On parcourt les lignes
For i = 2 To DerLig
' On récupère le Critere de la ligne
Critere = Left(Sheets("Suivi").Cells(i, IndiceColonne).Value, 10)
If Critere <> "" Then
' On va vérifier si la feuille existe
' Si elle n'existe pas
If VerifFeuille(Critere) = False Then
' On créé la feuille en dernier
Sheets.Add after:=Sheets(Sheets.Count)
' On la nomme
Sheets(Sheets.Count).Name = Critere
' On copie les titres
Set RDest = Sheets(Critere).Range(Cells(1, 1).Address, Cells(1, DerCol).Address)
RDest.Value = RTitres.Value
' Mise en forme
With RDest
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
End With
End If
' On cherche la ligne où l'on doit copier dans la feuille de destination
DerLigDest = Sheets(Critere).Cells(Rows.Count, 1).End(xlUp).Row + 1
' On déclare le range source de la ligne à copier
Set RSource = Sheets("Suivi").Range(Cells(i, 1).Address, Cells(i, DerCol).Address)
' On déclare le range où il faut copier la source
Set RDest = Sheets(Critere).Range(Cells(DerLigDest, 1).Address, Cells(DerLigDest, DerCol).Address)
' On copie la ligne
RDest.Value = RSource.Value
End If
Next i
' Pour chaque feuille dans la collection des feuilles
For Each Feuilles In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuilles.Name <> "Menu" And Feuilles.Name <> "Suivi" And Feuilles.Name <> "Annuaire" Then
' On ajoute la colonne Commentaire
Feuilles.Columns(12).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Feuilles.Cells(1, 12).Value = "Commentaire"
' On prend les colonnes du range des titres et on met leur taille en autofit
Feuilles.Range(Cells(1, 1).Address, Cells(1, DerCol + 1).Address).Columns.EntireColumn.AutoFit
End If
Next
' On se remet sur la feuille du début
Sheets("Suivi").Activate
' On remet le tri d'origine
Sheets("Suivi").Sort.SortFields.Clear
Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 1), Cells(DerLig, 1)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Sheets("Suivi").Sort.SortFields.Add Key:=Range(Cells(2, 2), Cells(DerLig, 2)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("Suivi").Sort
.SetRange Range(Cells(1, 1), Cells(DerLig, DerCol))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.ScreenUpdating = True
' Définition des variables
Dim OL As Object, myItem As Object, wDoc As Object, rng As Object
Dim Feuille As Worksheet, PlageFeuille As Range
'// assignation application Outlook
Set OL = CreateObject("Outlook.Application")
'// Pour chaque feuille dans la collection des feuilles
For Each Feuille In Worksheets
' Pour les feuilles autres que Menu, Suivi et Annuaire
If Feuille.Name <> "Menu" And Feuille.Name <> "Suivi" And Feuille.Name <> "Annuaire" Then
With Feuille
DerLig = Feuille.Cells(Rows.Count, 1).End(xlUp).Row
DerCol = Feuille.Cells(1, Columns.Count).End(xlToLeft).Column
' plage feuille à envoyer
Set PlageFeuille = Feuille.Range(Cells(1, 1).Address, Cells(DerLig, 12).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 = "monmail@mail.fr"
.To = Feuille.Cells(2, 13).Value
.Subject = "Relance " & Feuille.Cells(2, 20).Value
.Display
Set rng = wDoc.Content
' Corps du mail
rng.InsertParagraphBefore
rng.Move 4, -1
rng.InsertAfter "Bonjour," & vbNewLine
rng.InsertAfter vbNewLine & "Veuillez trouver ci-dessous les commandes non livrées que nous avons passées chez vous :" & vbNewLine
' Copie de la plage
rng.InsertParagraphAfter
rng.Move 4, 1
PlageFeuille.Copy
rng.Paste
rng.Move 4
rng.InsertAfter vbNewLine & vbNewLine & "Merci de nous dire quand le matériel correspondant sera livré ou de nous donner un nouveau délai de livraison." & 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
End With
End If
Next Feuille
'// Désassignation application Outlook
Set OL = Nothing
End Sub
Franchement, je m'attendais pas à ce que ça fonctionne aussi bien!
J'ai pu changer la couleur à l'aide d'un convertisseur online, remonter la plage dans le mail, et même mettre la taille de la police à 11, ce qui m'était auparavant impossible!
C'est vraiment génial! Première fois que je fais appel aux fofos pour avancer et je ne regrette pas du tout!
Un grand merci à toi thev, j'ai gagné quelques semaines de recherches grâce à toi!
Steelson, je garde ton code de côté, je suis persuadé de pouvoir utiliser tout ça quelque part! Merci pour ton aide!
A bientôt
Re
Finalement, il me reste encore un petit souci...
Après toutes ces modifications, mon .SentOnBehalfOfName ne modifie plus l'adresse d'envoi par défaut :/.
De base j'ai un compte outlook perso et des droits d'envoi sur une boîte générique.
Mon .SentOnBehalfOfName est sensé me permettre d'envoyer à partir de cette BAL générique de la part de ma boîte perso.
Mais là, ça ne modifie plus du tout comme avant, ça reste bloqué sur la boîte perso!
J'ai essayé plusieurs modifications mais rien de concluant...
Vous auriez une solution?
Encore merci :'(
- Messages
- 4'088
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonsoir,
Au lieu de
.SentOnBehalfOfName = "monmail@mail.fr"
Essaie
Dim compte as object
For Each compte In OL.Session.Accounts
If compte.SmtpAddress = "monmail@mail.fr" Then Set .SendUsingAccount = compte: Exit For
Next compte
Salut thev!
Je viens de tester ça mais ça ne fonctionne pas
Si je comprends bien le code que tu m'as envoyé, il sert à changer le compte utilisateur, donc si j'avais deux comptes associées à Outlook ça fonctionnerait.
Je pense que le souci vient du fait que la messagerie générique que j'utilise n'est pas un compte à part entière.
Il s'agit d'un compte associé au mien :
En gros, "maboîteperso" est ma boîte par défaut, celle qui me permet d'utiliser Outlook au travail.
"maboîtegénérique" est une boîte partagée ajoutée via les paramètres de "maboîteperso" (voir la PJ, j'ai du mal à expliquer clairement et ça sera plus parlant
Du coup lorsque j'envoie un mail, celui-ci part de "maboîtegénérique" de la part de "maboîteperso", cela permet à mon équipe d'avoir accès directement aux mails envoyés et aux réponses reçues ainsi que d'avoir des archives communes.
Je ne sais pas si je m'exprime clairement, c'est le matin là et je suis dans le brouillard
Merci quand même pour ton aide
Bonjour RyuMatsuda, le forum,
j'suis pas du tout calé en communications, mais juste à tout hasard, essaye sans mettre de guillemets :
Paramètres du Serveur
Serveur : serveurdemonentreprise
Nom d'utilisateur : maboîteperso
de plus, n'écrit pas tel quel le texte bleu !
exemple : Nom d'utilisateur : Ryu Matsuda
(mais si c'est à partir du code VBA, il faut bien les guillemets)
dhany
Salut dhany! Merci
En fait ce sont des valeurs que je ne peux pas modifier ça!
C'était juste pour essayer d'imager mon explication (le texte en rouge est la censure, confidentialité oblige
- Messages
- 4'088
- Excel
- 2021 FR 64 bits
- Inscrit
- 13/06/2016
- Emploi
- bénévole associations Goutte d'Or
Bonjour,
i je comprends bien le code que tu m'as envoyé, il sert à changer le compte utilisateur, donc si j'avais deux comptes associées à Outlook ça fonctionnerait.
Oui. Maintenant tu peux regarder le choix exact de comptes émetteur en mettant un arrêt après l'instruction ".Display", au niveau du bouton "De". Le code est en rapport avec ce choix.
Il faudrait essayer
au lieu de
If compte.SmtpAddress = "monmail@mail.fr"
plutôt
If compte.DisplayName = "monmail@mail.fr"
ou
If compte.UserName = "maboîtegénérique"
Pour ma culture, est-ce que cela fonctionnait ici : https://forum.excel-pratique.com/viewtopic.php?p=694814#p694814 ?Finalement, il me reste encore un petit souci...
Après toutes ces modifications, mon .SentOnBehalfOfName ne modifie plus l'adresse d'envoi par défaut :/.
Oui Steelson, ça fonctionnait
J'avais préconisé SendKeys, mais j'écris aussi parfois en html dans le VBAUne solution est d'utiliser sendkeys
Je dois aussi avoir un module qui crée le html en fonction de la zone (je vais rechercher)
A toutes fins utiles !
Je précise toutefois que :
- pour les mails j'utilise exclusivement sendkeys (c'est pourquoi je suis très intéressé par la méthode de Thev)
- mais quand ce n'est pas possible (exemple d'envoi de convocation par fichier joint .ics) alors j'emploie la transformation du texte en html
Salut tout le monde!
Après plusieurs tentatives, je n'y arrive toujours pas...
Je commence à désespérer! :'(
thev, j'ai essayé tes trois propositions, j'ai même tenté de les modifier en utilisant le négatif au lieu du positif (<>"mailperso" au lieu de ="mailgénérique") mais toujours pas, l'adresse de l'expéditeur reste ma boîte perso!
Merci quand même pour ton aide
Bonjour à tous,
Sujet non résolu mais je reviens clôturer le sujet.
Je travaille actuellement sur un nouveau projet dans lequel la solution à mon problème devra être trouvé.
Je vais recréer un sujet en partant de cette nouvelle base.
Merci à tous pour votre aide!