Pb ajout d'un tempo dans une macro

Version imprimable

Bon j'ai actuellement une macro qui fonctionne
en gros, quand je tape le chiffre 31 ou 34 ou 36 ou 18 ou 99 dans la colonne 21 ou 24 ou 27 ou 30 un mail est envoyé.

Alors j'aimerai améliorer l'envoie de l'email, en ce qui concerne le corps du message.
Actuellement je tape le code dans la colonne cible je table et hop le mail part direct

Apres avoir marquer le code, des explication sont donner dans la colonne après. Mais le mail est deja parti et les explications ne sont pas dans le mail du coup
J'ai pensé a mettre une tempo dans 45 seconde (largement suffisant) le temps que la personne marque les explication et que l'email body soit alimenté

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Dim tablCode
    tablCode = Array(31, 34, 36, 18, 99)
 
    If Target.Column = 21 Or Target.Column = 24 Or Target.Column = 27 Or Target.Column = 30 Then
        For i = 0 To 4
            If Target.Value = tablCode(i) Then 
           '--------------------------------------------------------
                Dim Email_Subject, Email_Send_From, Email_Send_To, _
                    Email_Cc, Email_Bcc, Email_Body As String
                Dim Mail_Object, Mail_Single As Variant
                Email_Subject = " DL " & tablCode(i)
                Email_Send_From = "xxxx@gmail.com"
                Email_Send_To = "xxxx@gmail.com"
                Email_Cc = "xxxx@gmail.com"
                Email_Bcc = "xxxx@gmail.com"
                Email_Body = "Auto-mail" & vbCr & _
                             "" & vbCr & _
                             "Un code " & tablCode(i) & " a été attribué aujourd'hui" & vbCr & _
                             "Date : " & Cells(Target.Row, 1) & vbCr & _
                             "Nom agent: " & Cells(Target.Row, 2) & vbCr & _
                             "Vol Départ: " & Cells(Target.Row, 13) & vbCr & _
                             "STD: " & Format(Cells(Target.Row, 18), "hh:mm") & vbCr & _
                             "ATD: " & Format(Cells(Target.Row, 19), "hh:mm") & vbCr & _
                             "Durée: " & Format(Cells(Target.Row, 20), "hh:mm") & vbCr & vbCr & _
                             "DR1: " & Cells(Target.Row, 21) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 22), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 23) & vbCr & vbCr & _
                             "dr2: " & Cells(Target.Row, 24) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 25), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 26) & vbCr & vbCr & _
                             "dr3: " & Cells(Target.Row, 27) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 28), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 29) & vbCr & vbCr & _
                             "dr4: " & Cells(Target.Row, 30) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 31), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 32) & vbCr & vbCr & _
                             "@tt"
 
 
                On Error GoTo debugs
                Set Mail_Object = CreateObject("Outlook.Application")
                Set Mail_Single = Mail_Object.CreateItem(0)
                With Mail_Single
                    .Subject = Email_Subject
                    .To = Email_Send_To
                    .cc = Email_Cc
                    .BCC = Email_Bcc
                    .Body = Email_Body
                    .Send
                End With
debugs:
                If Err.Description <> "" Then MsgBox Err.Description
                '----------------------------------------------------------------
            End If
 
        Next
    End If
End Sub

j'ai essayer d'ajouter application wait.. mais sa fonction pas comme je le voudrai
J'ai essayer avec application.ontime ... mais j'arrive pas a l'integgrer,

quelqu'un aurait-il une idée comment rajouté une tempo?
Merci

27/07/2015, 14h40
Quentin77170

De mémoire, au lieu de mettre .Send tu peux mettre .Show, ainsi ton mail sera tout prêt, plus qu'à le remplir et à cliquer toi-même sur Envoyer :)

Qu'en penses-tu ? Sinon insère un DoEvents juste avant ton Application.Wait, mais je ne suis pas certain du truc...
27/07/2015, 14h46
nicopof

En faite l'agent n'est pas censée écrire le mail, c'est juste un message d'info au chef de service, il est censé faire un rapport dans la foulé mais 70% du temps il ne le font pas.
Donc il me faut un mail auto
Alors soit une une tempo
Application.OnTime Now() + TimeValue("00:00:45"), "Module1.RetrieveValues" mais je ne sais pas comment l’insérer, ou soit j'ai pensée, après sauvegarde, le mail part!!!
27/07/2015, 14h50
bboy-eazy

Bonjour,

et l'agent rempli un case vide? Si oui pourquoi pas faire un test sur la cellule ou doit être inserer les commentaires et envoyer le mail que si la cellule commentaire est différentes de vide non?
27/07/2015, 14h55
nicopof

le probleme c'est que il remplisse que le code 99 pas les autres
27/07/2015, 15h05
mayekeul

Bonjour,

Le plus simple, serait simplement d'assigner l'envoi du mail, non pas au changement de valeur d'une cellule de la feuille mais à un bouton.
Quitte à tester des cellules si l'envoi doit bel et bien être fait.

Ca risque d'être compliqué à plus d'un titre de mettre un compte à rebours sur l'envoi du message en espérant que l'encodage soit fini.
27/07/2015, 15h17
nicopof

En ce qui concerne l'explication sa se réduit a quelque mots, actuellement le mail part quand l'agent écrit le code et tabule, comment envoyer le mail si, c'est pa l'agent qui écrit, mais si c'est c'est un résultat qui apparaît dans une case?
27/07/2015, 15h22
bboy-eazy
il suffit de mettre une condition
Code:

1 2 3 if 'la case est remplie '.. on envoi end if
27/07/2015, 15h22
mayekeul

Alors, il faut s'assurer que le mail est prêt à l'envoi avant de l'envoyer.... tout simplement.

Je ne vois pas d'autre solution.

enfin si, lancer un formulaire pour intégrer et/ou completer les commentaires dans la feuille de calcul qui une fois validé enverra le message

Code:

1
2
3
4
5
6
7
8
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim tablCode
tablCode = Array(31, 34, 36, 18, 99)
 
If Target.Column = 21 Or Target.Column = 24 Or Target.Column = 27 Or Target.Column = 30 Then
For i = 0 To 4
If Target.Value = tablCode(i) Then

tu integre comment la seconde condition ici?
colonne 23 26 29 ou 32 si la cellule <>""

27/07/2015, 15h38
kiki29

Salut, Balise ton code stp
27/07/2015, 15h40
nicopof

c'est a dire?

si les commentaires sont dans ces colonnes oui tu peux faire:

Code:

1
2
3
If (Target.Column = 23 Or Target.Column = 26 Or Target.Column = 29 Or Target.Column = 32) And Target.Value <> "" Then
'envoi du mail
End If

27/07/2015, 18h32
Invité

Bonjour,
Si la cellule de commentaire est vide un inputbox invite l'utilisateur a entré son commentaire; la voilà ta tempo!
28/07/2015, 02h04
nicopof

tu l'introduirais comment dans la formule?

1 pièce(s) jointe(s)

Bonjour,

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
Dim NoFin As Boolean
Private Sub CommandButton1_Click()
Me.Hide
End Sub
Public Function Valider(L As Long) As Boolean
NoFin = True
Me.TextBox1 = Trim("" & Cells(L, 23))
Me.TextBox2 = Trim("" & Cells(L, 26))
Me.TextBox3 = Trim("" & Cells(L, 29))
Me.TextBox4 = Trim("" & Cells(L, 32))
 
Me.Show 1
Cells(L, 23) = Me.TextBox1
Cells(L, 26) = Me.TextBox2
Cells(L, 29) = Me.TextBox3
Cells(L, 32) = Me.TextBox4
Valider = True
If Trim("" & Cells(L, 23)) = "" Or Trim("" & Cells(L, 26)) = "" _
    Or Trim("" & Cells(L, 29)) = "" Or Trim("" & Cells(L, 32)) = "" Then Valider = False
NoFin = False
Unload Me
End Function
 
Private Sub UserForm_Click()
 
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Cancel = NoFin
End Sub
 
Private Sub UserForm_Terminate()
 
End Sub

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
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim Ok As Boolean
    If Target.Count > 1 Then Application.EnableEvents = True:   Exit Sub
    Dim tablCode
    tablCode = Array(31, 34, 36, 18, 99)
     Ok = True
    If Target.Column = 21 Or Target.Column = 24 Or Target.Column = 27 Or Target.Column = 30 Then
    If Trim("" & Cells(Target.Row, 23)) = "" Or Trim("" & Cells(Target.Row, 26)) = "" _
    Or Trim("" & Cells(Target.Row, 29)) = "" Or Trim("" & Cells(Target.Row, 32)) = "" Then Ok = False
        Do While Ok = False
            Ok = UserForm1.Valider(Target.Row)
        Loop
        For i = 0 To 4
            If Target.Value = tablCode(i) Then
            '--------------------------------------------------------
                Dim Email_Subject, Email_Send_From, Email_Send_To, _
                    Email_Cc, Email_Bcc, Email_Body As String
                Dim Mail_Object, Mail_Single As Variant
                Email_Subject = " DL " & tablCode(i)
                Email_Send_From = "xxxx@gmail.com"
                Email_Send_To = "xxxx@gmail.com"
                Email_Cc = "xxxx@gmail.com"
                Email_Bcc = "xxxx@gmail.com"
                Email_Body = "Auto-mail" & vbCr & _
                             "" & vbCr & _
                             "Un code " & tablCode(i) & " a été attribué aujourd'hui" & vbCr & _
                             "Date : " & Cells(Target.Row, 1) & vbCr & _
                             "Nom agent: " & Cells(Target.Row, 2) & vbCr & _
                             "Vol Départ: " & Cells(Target.Row, 13) & vbCr & _
                             "STD: " & Format(Cells(Target.Row, 18), "hh:mm") & vbCr & _
                             "ATD: " & Format(Cells(Target.Row, 19), "hh:mm") & vbCr & _
                             "Durée: " & Format(Cells(Target.Row, 20), "hh:mm") & vbCr & vbCr & _
                             "DR1: " & Cells(Target.Row, 21) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 22), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 23) & vbCr & vbCr & _
                             "dr2: " & Cells(Target.Row, 24) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 25), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 26) & vbCr & vbCr & _
                             "dr3: " & Cells(Target.Row, 27) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 28), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 29) & vbCr & vbCr & _
                             "dr4: " & Cells(Target.Row, 30) & vbCr & _
                             "time: " & Format(Cells(Target.Row, 31), "hh:mm") & vbCr & _
                             "Explication: " & Cells(Target.Row, 32) & vbCr & vbCr & _
                             "@tt"
 
 
                On Error GoTo debugs
                Set Mail_Object = CreateObject("Outlook.Application")
                Set Mail_Single = Mail_Object.CreateItem(0)
                With Mail_Single
                    .Subject = Email_Subject
                    .To = Email_Send_To
                    .cc = Email_Cc
                    .BCC = Email_Bcc
                    .Body = Email_Body
                    .Send
                End With
debugs:
                If Err.Description <> "" Then MsgBox Err.Description
                '----------------------------------------------------------------
            End If
 
        Next
    End If
    Application.EnableEvents = True
End Sub