MACRO - Envoi mail si données avec filtre
Bonjour,
Je me permets de venir appeler à l’aide pour un problème sur une macro que je souhaite créer.
Dans mon tableau, j’ai réussi à mettre en place avec des bouts de codes trouvés sur internet une grande partie de ce que je souhaitais (aucune idée si le code est le + simple mais il fonctionne
Voilà ce qui me fait buger désormais.
Sur l’onglet « MAIL » du fichier en pièce jointe, l’utilisateur doit pouvoir sélectionner le « fourn » et le mois souhaité.
Ensuite, en cliquant sur le bouton « Envoi du mail », ça enverra automatiquement les données de l’onglet correspondant au fourn choisi et à la période souhaitée (prévenir si aucune donnée et ne pas envoyer de mail).
En colonne « C » sur les onglets des fourn se trouvent les dates, et donc les périodes.
Le(s) mail(s) de contact sera(ont) les données de la colonne « C » ou de la cellule « G9 » de l'onglet "MAIL"
Enfin, si le fourn est « tous », cela crée un mail pour tous les fourn mais séparément (30 mails pré-remplis par exemple).
A savoir que les colonnes A, B et C de l’onglet « MAIL » seront masquées et je serai le seul à modifier les contacts.
Voici un code top que j’ai déjà utilisé pour un autre tableau, si ca peut mettre des personnes sur la piste
Sub EnvoiMail()
If MsgBox("Envoyer la demande aux personnes concernées ?", 36, "Confirmation") = vbYes Then
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Demande ").Range("B1:J46").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "Erreur de sélection" & _
vbNewLine & "Contacter OIIR", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "aaa.bbb@CCC.com"
.CC = ""
.BCC = ""
.Subject = "Demande d'accès " & Range("D21").Value & " (" & Range("D25").Value & ")"
.HTMLBody = RangetoHTML(rng)
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Le mail a été envoyé"
End If
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Excellente journée et un grand merci d’avance,
Loïc
Bonjour à tous,
Pour information, j'ai déjà réussi à avancer sur une partie du sujet :
Désormais j'arrive à envoyer le mail d'après le fourn. et à l'adresse mail correspondante à ce fourn.
Mes problèmes persistants sont :
- le filtrage du mois
- la selection des données dans l'onglet (inclues entre les colonnes A et J mais lignes variables)
- prévenir si aucune donnée à envoyer
- envoyer plusieurs mails si "tous" est sélectionné.
Je vous mets en pièce jointe le tableau mis à jour.
Bonne journée,
Loïc