Problème avec alerte mail via outlook VBA

Version imprimable

Bonjour,
j'ai un soucis et je vous prie de m'aider svp. En fait j'ai fait une alerte mail qui me prévient de l'arrivée d'une date, j'ai crée une macro pour cela(elle fonctionne très bien) que j'ai associé a l'ouverture de mon fichier. Mais en fait je voudrais que cet alerte m'envoi seulement 2 fois le mail d'alerte pour chaque date qui approche. Plus précis je ne voudrais pas qu'elle envoi un mail ( si ces mail concernent la même échéance) à chaque fois que j'ouvre le fichier mais seulement deux fois.
Voici mon code. Est ce que vous pouvez me proposer des solutions de modifications pour cela SVP???
Merci d'avance

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Private Sub Workbook_Open()
' inser2 dans thisworkbook
 
'
 
Dim Ws As Worksheet
Dim Mbody As String 'le corps du message
Dim desti As String
Dim sujet As String
Dim i As Integer
Dim Der_lig As Integer
 
On Error GoTo ende
sujet = "SUJET ALERTE"
desti = "MAIL DU DESTINATAIRE"
'ccto = "xxxxxxx"
Mbody = "CORPS DU MAIL" & vbCrLf & "cordialement" & vbCrLf & "XXXXXX"
Set Ws = Sheets("Feuil1") 'ActiveSheet
 Der_lig = Range("D65000").End(xlUp).Row + 1
    For i = 1 To Der_lig
        ' -2 < Date livraison >= 3
        If Cells(i, "G").Value <= Date + 2 And Cells(i, "G").Value > Date - 2 Then     'And Cells(i, "G").Value <> ""
            Mbody = Mbody & (Cells(i, "D").Value) '& " sa date de livraison est prévu le " & (cellule) '& vbCrLf & "Cordialement" & vbCrLf & "Alerte Automatique"   'pour chercher le nom du rapport
        'Else: Mbody = "Pas de dates de livraison proches"
        End If
    Next i
Set app = CreateObject("outlook.application")
Set itm = app.createitem(0)
    With itm
        .To = desti 'l'adresse du destinataire
        .cc = ccto  'l'adresse de l'envoyeur
        .Subject = sujet 'sujet du mail
        .body = Mbody  'le corps du message
        '.AddAttachment ("c:cheminfichier.ext") 'Pour éventuellement joindre un fichier
        '.Cc = "LeCC" & Chr(64) & "hotmail.com" 'Pour mettre quelqu'un en CC
        .Display
        '.Send
    End With
Set app = Nothing
Set itm = Nothing
ende:
End Sub

Bonjour pasterlouis,

je ne suis pas sûr d'avoir bien saisi tout le problème mais si j'ai bien compris tu veut que l'envoi des mails s'effectue une seule fois par jours au max ?

Pour cela je te conseille d'utiliser une cellule de ta feuille pour stocker la date du dernier traitement.

Si la date du dernier traitement est différente de la date du jour tu fais ton traitement puis à la fin tu update ta date de dernier traitement sinon ben tu fais rien

donc juste un if à rajouter

Voilà ce que ça donne :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Private Sub Workbook_Open()
' inser2 dans thisworkbook
 
'
 
Dim Ws As Worksheet
Dim Mbody As String 'le corps du message
Dim desti As String
Dim sujet As String
Dim i As Integer
Dim Der_lig As Integer
 
If Range("xxxxxxx") <> Date Then
    On Error GoTo ende
    sujet = "SUJET ALERTE"
    desti = "MAIL DU DESTINATAIRE"
    'ccto = "xxxxxxx"
    Mbody = "CORPS DU MAIL" & vbCrLf & "cordialement" & vbCrLf & "XXXXXX"
    Set Ws = Sheets("Feuil1") 'ActiveSheet
     Der_lig = Range("D65000").End(xlUp).Row + 1
        For i = 1 To Der_lig
            ' -2 < Date livraison >= 3
            If Cells(i, "G").Value <= Date + 2 And Cells(i, "G").Value > Date - 2 Then     'And Cells(i, "G").Value <> ""
                Mbody = Mbody & (Cells(i, "D").Value) '& " sa date de livraison est prévu le " & (cellule) '& vbCrLf & "Cordialement" & vbCrLf & "Alerte Automatique"   'pour chercher le nom du rapport
            'Else: Mbody = "Pas de dates de livraison proches"
            End If
        Next i
    Set app = CreateObject("outlook.application")
    Set itm = app.createitem(0)
        With itm
            .To = desti 'l'adresse du destinataire
            .cc = ccto  'l'adresse de l'envoyeur
            .Subject = sujet 'sujet du mail
            .body = Mbody  'le corps du message
            '.AddAttachment ("c:cheminfichier.ext") 'Pour éventuellement joindre un fichier
            '.Cc = "LeCC" & Chr(64) & "hotmail.com" 'Pour mettre quelqu'un en CC
            .Display
            '.Send
        End With
    Set app = Nothing
    Set itm = Nothing
    Range("xxxxxxxxxx") = Date ' Update '
End If
ende:
End Sub

tu remplace range("xxxxxxxx") par ta cellule choisie

14/05/2013, 21h45
pasterlouis

Merci beaucoup Halo2550.
En fait j'ai pas bien compris ce que tu a dit. Je devrai seulement insérer comme tu l'a fait

Code:

range(feuile)=date

dans mon code ou il y'a une condition comme quoi si ce qui est contenu dans cette cellule est = date alors ne pas envoyé. Si c'est cela je n'ai pas d'idée de comment je ferai cette condition
15/05/2013, 10h15
pasterlouis

Merci beaucoup Halo2550
mon pb est réglé