Discussion :

[AudREN]

Bonjour,

ce code VBA qui fonctionne à merveille merci Claude Leloup, j'ai juste besoin de rajouter dans le recordset une adresse mail supplémentaire que j'ai rajouté dans ma table T_Territoires et qui s'appelle Mail_Territoire2.

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
Option Compare Database
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Sub EnvoiCopies(Optional DateJour As Date)
  Dim rs As Recordset
  Dim q As QueryDef
  Dim wdApp As Word.Application
  Dim ret As Integer
  Dim objOutlook As Outlook.Application
  Dim MonMessage As Object
  'Si pas de date en paramètre, date du jour
  If DateJour = #12:00:00 AM# Then DateJour = Date
  'Assigner Word
  Set wdApp = New Word.Application
  'Assigner la requête rRemake
  Set q = CurrentDb.QueryDefs("rRemake")
  'Créer un RecordSet des destinataires concernés
  Set rs = CurrentDb.OpenRecordset("SELECT Distinct Mail_Territoire FROM R_Publipostage_Rdv1 WHERE Date_lettre1=#" & Format(DateJour, "mm/dd/yy") & "#;")
  'Traiter chaque destinataire l'un après l'autre
  Do Until rs.EOF
    'Aménager la requête rRemake pour choisir les items du destinataire en cours
    q.SQL = "SELECT * FROM R_Publipostage_Rdv1 WHERE Mail_Territoire=""" & rs(0) & """;"
    'Remake du publipostage
    With wdApp
       .Visible = True
       .Documents.Open CurrentProject.Path & "\LettreType\Lettre _Type_RDV1.doc"
       .ActiveDocument.MailMerge.OpenDataSource _
            Name:=CurrentDb.Name, _
            LinkToSource:=True, _
            Connection:="Query rRemake", _
            SQLStatement:="SELECT * FROM [rRemake]"
       .ActiveDocument.MailMerge.Execute
       .ActiveDocument.SaveAs CurrentProject.Path & "\LettreType\" & Format(DateJour, "yyyymmdd") & "Copies.doc"
       .Documents.Close
    End With
    'Envoyer l'e-mail
    'ouvrir OutLook
    ret = Shell("C:\Program Files (x86)\Microsoft Office\Office14\OUTLOOK.EXE", vbHide) 'À adapter
    'Envoyer le mail
    'Assigner l'objet Outlook
    Set objOutlook = New Outlook.Application
    'Composer le message
    Set MonMessage = objOutlook.createitem(0)
    MonMessage.To = TransfoMail(rs(0))
    MonMessage.Subject = "Copie des lettres de proposition rdv1 dans le cadre des enquêtes financières et sociales à destination du juge"
    MonMessage.Body = "Expérimentation sur la CCPR. Bonne journée."
    MonMessage.Attachments.Add CurrentProject.Path & "\LettreType\" & Format(DateJour, "yyyymmdd") & "Copies.doc"
    MonMessage.send
 
    'Fermer Outlook
    Sleep 2000 'temporiser 2 secondes pour laisser à Outlook le temps d'envoyer (on peut sans doute réduire)
    KillApp (ret)
    Set MonMessage = Nothing
    Set objOutlook = Nothing
 
    'Au suivant
    rs.MoveNext
  Loop
  'Fermer et libérer les objets
  wdApp.Quit
  Set wdApp = Nothing
  rs.Close
  'Supprimer le dernier .doc envoyé
  Kill CurrentProject.Path & "\LettreType\" & Format(DateJour, "yyyymmdd") & "Copies.doc"
End Sub
 
Public Function TransfoMail(original As String) As String
  Dim tableau() As String
  tableau = Split(original, "#")
  TransfoMail = tableau(0)
End Function

Ma question est donc de savoir comment modifier pour que ces documents puissent être envoyés sur 2 adresses mail.

Dans la requête rRemake, dans le q.SQL et dans TransfoMail ?

En vous remerciant de me lire pour m'aider!
bonne fin de journée

[ClaudeLELOUP]

Bonjour,


Il faut modifier à 2 endroits :

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
Option Compare Database
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Sub EnvoiCopies(Optional DateJour As Date)
  Dim rs As Recordset
  Dim q As QueryDef
  Dim wdapp As Word.Application
  Dim ret As Integer
  Dim objOutlook As Outlook.Application
  Dim MonMessage As Object
  'Si pas de date en paramètre, date du jour
  If DateJour = #12:00:00 AM# Then DateJour = Date
  'Assigner Word
  Set wdapp = New Word.Application
  'Assigner la requête rRemake
  Set q = CurrentDb.QueryDefs("rRemake")
  'Créer un RecordSet des destinataires concernés
'''''''''''''''''''''''Modif''''''''''''''''
   Set rs = CurrentDb.OpenRecordset("SELECT Distinct Mail_Territoire,Mail_Territoire2 FROM R_Publipostage_Rdv1 WHERE Date_lettre1=#" & Format(DateJour, "mm/dd/yy") & "#;")
  'Traiter chaque destinataire l'un après l'autre
  Do Until rs.EOF
    'Aménager la requête rRemake pour choisir les items du destinataire en cours
    q.SQL = "SELECT * FROM R_Publipostage_Rdv1 WHERE Mail_Territoire=""" & rs(0) & """;"
    'Remake du publipostage
    With wdapp
       .Visible = True
       .Documents.Open CurrentProject.Path & "\LettreType\Lettre_Type_RDV1.doc"
       .ActiveDocument.MailMerge.OpenDataSource _
            Name:=CurrentDb.Name, _
            LinkToSource:=True, _
            Connection:="Query rRemake", _
            SQLStatement:="SELECT * FROM [rRemake]"
       .ActiveDocument.MailMerge.Execute
       .ActiveDocument.SaveAs2 CurrentProject.Path & "\LettreType\" & Format(DateJour, "yyyymmdd") & "Copies.doc"
       .Documents.Close
    End With
    'Envoyer l'e-mail
    'ouvrir OutLook
    ret = Shell("C:\Program Files (x86)\Microsoft Office\Office14\OUTLOOK.EXE /profile adl", vbHide) 'À adapter
    'Envoyer le mail
    'Assigner l'objet Outlook
    Set objOutlook = New Outlook.Application
    'Composer le message
    Set MonMessage = objOutlook.createitem(0)
''''''''''''''''''''''''''''''''''Modif ici
    MonMessage.To = TransfoMail(rs(0)) & ";" & TransfoMail(rs(1))
    MonMessage.Subject = "Copie des lettres"
    MonMessage.Body = "Bonne journée."
    MonMessage.Attachments.Add CurrentProject.Path & "\LettreType\" & Format(DateJour, "yyyymmdd") & "Copies.doc"
    MonMessage.send
 
    'Fermer Outlook
    Sleep 2000 'temporiser 2 secondes pour laisser à Outlook le temps d'envoyer (on peut sans doute réduire)
    KillApp (ret)
    Set MonMessage = Nothing
    Set objOutlook = Nothing
 
    'Au suivant
    rs.MoveNext
  Loop
  'Fermer et libérer les objets
  wdapp.Quit
  Set wdapp = Nothing
  rs.Close
  'Supprimer le dernier .doc envoyé
  Kill CurrentProject.Path & "\LettreType\" & Format(DateJour, "yyyymmdd") & "Copies.doc"
End Sub