Menu

Envoi mail 1 fois par semaine excel vba [Résolu]

pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 4 avril 2018 à 12:09 - Dernière réponse : pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention
- 16 avril 2018 à 09:45
Bonjour,

Je souhaite envoyer un mail 1 fois par semaine à certaines conditions...

L'idéal serait que la macro soit exécuté, une fois par semaine sans ouvrir le fichier, mais est-ce possible ?

Actuellement, c'est opérationnel, le lundi, mais avec le lundi de pâques, non travaillé.....

Plutôt que de spécifier le jour, je souhaite que la macro envoie un mail une seule fois, dans la semaine qu'importe le jour.....



Voici la macro en cours d'écriture...

Private Sub Workbook_Open()
Dim Desti As String, Feuille As String, TCD As String
Dim Fichier As String, Plage As Range
'
Worksheets("Données pour mail").Visible = True
Sheets("Données pour mail").Select
If Application.Weekday(Date) = 2 Then
i = 5
While Cells(i, 19).Value <> ""
i = i + 1
Wend
Cells(i, 19).Value = Date

If Application.Weekday(Date) = 2 Then 'le message est expédié tous les lundis
Fichier = "SUIVI FLOTTE.xlsm" 'le fichier doit être ouvert
Feuille = "Données pour mail" 'nom de la feuille
TCD = "Tableau4" 'nom
With Workbooks(Fichier).Sheets(Feuille)
Set Plage = .Range("a1:h42")
End With
Desti = Range("m13") 'destinataire du message
DestiCc = Range("m13") 'destinataire du message
EnvoiTCD Plage, Desti
End If
End If
Sheets("Base").Select
Worksheets("Données pour mail").Visible = False
End Sub

Function EnvoiTCD(Plage As Range, Desti As String)
Dim OutApp As Object, OutMail As Object
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 = Desti
.CC = DestiCc
.BCC = ""
.Subject = "Rappel Contrôle Technique et/ou Révision à effectuer - Message automatique - Ne pas répondre SVP"
.HTMLBody = RangetoHTML(Plage)
.Send 'or use .Display
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
Sheets("Base").Select
End Function
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

'Publish the sheet to a htm file
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

'Read all data from the htm file into RangetoHTML
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=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
Sheets("Base").Select
End Function


Merci d'avance !

pygos
Afficher la suite 

Votre réponse

12 réponses

pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 5 avril 2018 à 09:09
0
Merci
Plutôt que de spécifier le jour, je souhaite que la macro envoie un mail une seule fois, dans la semaine qu'importe le jour.....
pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 9 avril 2018 à 15:34
Si, j'ai ouvert le fichier 3 fois, la date a bien été généré, la 1ère fois, mais 3 mails sont partis....
yg_be 6032 Messages postés lundi 9 juin 2008Date d'inscriptionContributeurStatut 21 juillet 2018 Dernière intervention > pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 9 avril 2018 à 16:42
et le fichier était sauvé avant d'être rouvert?
pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 9 avril 2018 à 17:31
Je n'avais pas pensé à cela, je dois imposer l'enregistrement du fichier ?
yg_be 6032 Messages postés lundi 9 juin 2008Date d'inscriptionContributeurStatut 21 juillet 2018 Dernière intervention > pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 9 avril 2018 à 18:35
comme c'est dans le fichier que la date d'envoi est enregistrée, cette date sera oubliée si le fichier n'est pas sauvé.
pygos 155 Messages postés vendredi 5 septembre 2008Date d'inscription 19 juillet 2018 Dernière intervention - 16 avril 2018 à 09:45
Merci, j'ai rajouté :

Application.OnTime Now + TimeValue("00:00:05"), "EnregistrerFichier"
Commenter la réponse de pygos