Discussion :

[eric4459]

L'objectif de code est de répondre au besoin suivant:

Envoyer par email de façon périodique un planning vierge aux membres de l'équipe pour une période définie et de demander un retour avant une date donnée.

Il faut pouvoir supprimer l'adresse d'un des membres et/ ou ajouter l'adresse d'un nouveau membre.

Le classeur de travail contient 3 onglets :

Un onglet à partir duquel on lancera la macro, un second contenant les données à envoyer et le dernier contenant la liste des destinataires en colonne A

Le fichier joint ne doit pas contenir la macro qui se trouve sur le fichier

La macro est lancée depuis une feuille à l'aide d'un bouton créé à l'aide des formes Excel.

J'ai donc créé deux formulaires :

Le premier, contenant deux TextBox, permet de définir la période et la date limite de réception de la réponse.

Le second, contenant une Combox Box qui sera alimentée avec la liste des destinataires et une TextBox qui recevra une nouvelle adresse.


Voici le code du premier formulaire:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub Btok_Click()
Dim Rec As Worksheet
Dim A As Long
Set Rec = ThisWorkbook.Sheets("Recipient")
 
        Rec.Range("C1").Value = Period.TextBox1.Value 'enregistre la période pour l'insérer ensuite dans le mail
        Rec.Range("C2").Value = Period.TextBox2.Value   'enregistre la date limite de reception de la réponse pour l'insérer dans le mail
 
 
       Unload Me
 
   A = MsgBox("Voulez-vous modifier la liste des destinataires ? ", vbYesNo + vbExclamation, "Warning")
    If A = vbYes Then
    Mail_list
    Else
    Send_Mail
    End If
End Sub

Voici le code du deuxième formulaire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub BtOk2_Click()
Dim Rec As Worksheet
Dim Rcpt As Range
Dim NbLine1 As Integer
Set Rec = ThisWorkbook.Sheets("Recipient")
Set Rcpt = Rec.Range("A1")
Rcpt = Rcpt.Offset(0)
 
 With Sheets("Recipient")
        NbLine1 = .Cells(.Rows.Count, 1).End(xlUp).Row  ' On compte le nombre de ligne
 End With
 
  If TextBox1.Value <> "" Then
    Rcpt.Offset(NbLine1, 0).Value = TextBox1.Value ' si on ajoute une adresse mail on l'enregistre à la fin de la liste existante
 End If
 
 For i = 1 To NbLine1
    If Rcpt.Offset(i - 1, 0) = ComboBox1.Value Then 'ici on supprime un destinataire de la liste
       Rec.Rows(i).Delete
        Exit For
    End If
 Next i
 
 
 
Me.Hide
 
Send_Mail ' on appelle la procédure "Send_Mail"
 
End Sub

Enfin, voici les procédures intégrées dans un module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
69
70
71
72
73
74
75
Option Explicit
Sub Prepare_Email_Click()
Period.Show
End Sub
Sub Send_Mail()
 
Dim ol As Object, myItem As Object
Dim List As String
Dim ListDest As String
Dim Chemin As String
Dim Rec As Worksheet
Dim Rcpt As Range
Dim NbLine As Integer
Dim FileName As String
Set Rec = ThisWorkbook.Sheets("Recipient")
Set Rcpt = Rec.Range("A1")
Rcpt = Rcpt.Offset(0)
Set ol = CreateObject("outlook.application")
Set myItem = ol.CreateItem(olMailItem)
Set SourceFile1 = ActiveWorkbook
Chemin = ThisWorkbook.Path
    With Sheets("Recipient")
        NbLine = .Cells(.Rows.Count, 1).End(xlUp).Row  ' On compte le nombre de ligne
    End With
 
FileName = Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) - 5) ' on défini le nom du fichier
Worksheets("Workload").Copy ' on copie la feuille qui sera envoyée par mail
ActiveWorkbook.SaveAs Chemin & "\" & FileName & "_" & ".xlsx" ' on enregistre le nouveau fichier au format xlsx
                                                              ' de cette façon le fichier envoyè ne contiendra pas de macro
ActiveWorkbook.Close ' ferme le nouveau fichier
 
For i = 0 To NbLine - 1
If Rcpt.Offset(i, 0) <> "" Then
List = List & ";" & Rcpt.Offset(i, 0) 'ici on génère la liste des destinataires
                                      '(toutes les adresses mail sont en colonne A de la feuille "Recipient")
End If
Next i
 
ListDest = List ' Ici on affecte tous les destinataires
myItem.cc = Rcpt.Offset(0, 1) ' Ici on défini la personne en copie (Le chef ;-) )
myItem.To = ListDest ' Ici on affecte tous les destinataires
myItem.Subject = "2 Weeks Look-Ahead Schedule" ' Titre du mail
' Ci-dessous on génère le texte du mail
myItem.Body = "Chers collègues," & _
vbCrLf & vbCrLf & _
"Afin d'avoir une vision du travail pour les deux prochaines semaines, merci de remplir le planning joint et de me le retourner dès que possible." & _
vbCrLf & _
"Periode " & Rcpt.Offset(0, 2) & "." & _
vbCrLf & _
"Je dois recevoir votre contribution avant " & Rcpt.Offset(1, 2) & "." & _
vbCrLf & _
"Merci de préciser le/les numéros de projets sur lequel(s) vous travaillez." & _
 vbCrLf & _
 "Cordialement" & _
 vbCrLf & _
 "Votre serviteur"
myItem.Attachments.Add ActiveWorkbook.FullName ' fichier attaché au mail
myItem.Send
Set ol = Nothing
 
End Sub
 
Sub Mail_list()
Dim Nbline2 As Integer
Dim Rec As Worksheet
Set Rec = ThisWorkbook.Sheets("Recipient")
    With Sheets("Recipient")
        Nbline2 = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 ' On compte le nombre de ligne
    End With
 
    Recipient.ComboBox1.List = Rec.Range("A1" & ":" & "A" & Nbline2).Value ' Ici on affecte la liste de mail  à la Combox box
 
    Recipient.Show
 
End Sub

Je pense qu'il est possible de simplifier ou d'améliorer ce code, on peux même revoir la philosophie, quoiqu'il en soit je le mets à votre disposition pour tout ou partie.

Eric

[eric4459]

Petite modif pour l'envoi du fichier sans macro

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Send_Mail()
 
Dim ol As Object, myItem As Object
Dim List As String
Dim ListDest As String
Dim Chemin As String
Dim Rec As Worksheet
Dim Rcpt As Range
Dim NbLine As Integer
Dim FileName As String
Dim Attachment As String
Set Rec = ThisWorkbook.Sheets("Recipient")
Set Rcpt = Rec.Range("A1")
Rcpt = Rcpt.Offset(0)
Set ol = CreateObject("outlook.application")
Set myItem = ol.CreateItem(olMailItem)
Set SourceFile1 = ActiveWorkbook
Chemin = ThisWorkbook.Path
    With Sheets("Recipient")
        NbLine = .Cells(.Rows.Count, 1).End(xlUp).Row  ' On compte le nombre de ligne
    End With
 
FileName = Mid(ThisWorkbook.Name, 1, Len(ThisWorkbook.Name) - 5) ' on défini le nom du fichier
Worksheets("Workload").Copy ' on copie la feuille qui sera envoyée par mail
ActiveWorkbook.SaveAs Chemin & "\" & FileName & "_" & ".xlsx" ' on enregistre le nouveau fichier au format xlsx
Attachment = Chemin & "\" & FileName & "_" & ".xlsx"                                                       ' de cette façon le fichier envoyè ne contiendra pas de macro
ActiveWorkbook.Close ' ferme le nouveau fichier
 
For i = 0 To NbLine - 1
If Rcpt.Offset(i, 0) <> "" Then
List = List & ";" & Rcpt.Offset(i, 0) 'ici on génère la liste des destinataires
                                      '(toutes les adresses mail sont en colonne A de la feuille "Recipient")
End If
Next i
 
ListDest = List ' Ici on affecte tous les destinataires
myItem.cc = Rcpt.Offset(0, 1) ' Ici on défini la personne en copie (Le chef ;-) )
myItem.To = ListDest ' Ici on affecte tous les destinataires
myItem.Subject = "2 Weeks Look-Ahead Schedule" ' Titre du mail
' Ci-dessous on génère le texte du mail
myItem.Body = "Chers collègues," & _
vbCrLf & vbCrLf & _
"Afin d'avoir une vision du travail pour les deux prochaines semaines, merci de remplir le planning joint et de me le retourner dès que possible." & _
vbCrLf & _
"Periode " & Rcpt.Offset(0, 2) & "." & _
vbCrLf & _
"Je dois recevoir votre contribution avant " & Rcpt.Offset(1, 2) & "." & _
vbCrLf & _
"Merci de préciser le/les numéros de projets sur lequel(s) vous travaillez." & _
 vbCrLf & _
 "Cordialement" & _
 vbCrLf & _
 "Votre serviteur"
myItem.Attachments.Add Attachment ' fichier attaché au mail
myItem.Send
Set ol = Nothing
 
End Sub