While ne fonctionne pas

**possible924** · 29/08/2019, 10h59

Bonjour à tous,
J'essaie de faire une boucle mais ça ne fonctionne pas bien

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
Set RS = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
While Not RS.EOF 'tant que non fin liste des enregistrements
    If Not IsNull(RS.Lien) Then 'test champs Sp_Lien
        'Dim PièceJointe01 As String
        PièceJointe01 = RS.Lien 'recordset sur le champs Email
    End If
    'Me.Test = PièceJointe01
RS.MoveNext
    If Not IsNull(RS.Lien) Then
        'Dim PièceJointe02 As String
        PièceJointe02 = RS.Lien
    End If
RS.MoveNext
    If Not IsNull(RS.Lien) Then
        'Dim PièceJointe03 As String
        PièceJointe03 = RS.Lien
    End If
RS.MoveNext
Wend

A la PièceJointe03 = RS.Lien, j'obtiens je message d'erreur

"Erreur 3021 Aucun enregistrement en cours"

Je contourne le problème avec On Error GoTo Suite, mais ce n'est pas très joli.

merci par avance pour votre aide
Pierre

**Phiphi41** · 29/08/2019, 11h07

Bonjour

Essayes en mettant les RS.MoveNext dans chaque boucle IF et non à l'extérieur de celle-ci.

Car en fait tu avances de 3 enregistrements à chaque fois.

**possible924** · 29/08/2019, 11h25

Merci pour la réponse
Je n'avance pas de trois enregistrements, en fait, j'ai deux enregistrements à envoyer,
le problème est que le While ne s'arrête pas au dernier enregistrement disponible.
J'ai déplacé le MoveNext, ça ne change rien

**Phiphi41** · 29/08/2019, 11h28

Pourquoi tu fais 3 fois le même test ?

**possible924** · 29/08/2019, 16h40

Merci pour la question, mais je ne connais pas la réponse,
Peux tu m'en dire plus ?
Pierre

**Phiphi41** · 29/08/2019, 16h55

Pourquoi ne pas faire cela :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Set RS = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
While Not RS.EOF 'tant que non fin liste des enregistrements
 
    If Not IsNull(RS.Lien) Then 'test champs Sp_Lien
        'Dim PièceJointe01 As String
        PièceJointe01 = RS.Lien
        PièceJointe02 = RS.Lien 'recordset sur le champs Email
       PièceJointe03 = RS.Lien
    End If
 
RS.MoveNext
 
Wend

**Thierry_PALLIER** · 29/08/2019, 17h31

Bonjour.

Celà serai bien de connaitre le contexte, si le nombre de PièceJointe0X est fixe et ne varie pas, obligation de les déclarés, portée de ses variables ...?

Mettre tous çà dans un tableau dynamique pourrait etre interessant :

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
Sub ess2()
    Dim i As Byte
    Dim TabVariable As Variant
    Dim rs As DAO.Recordset
 
 
 
    Set rs = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
     rs.MoveLast
    rs.MoveFirst
 
    ReDim TabVariable(1 To 2, 1 To 1) As String
 
 
    TabVariable(1, 1) = "Lien"
    TabVariable(2, 1) = "numero"
 
    For i = 1 To rs.RecordCount
 
 
        If Not IsNull(rs!Lien) Then    'test champs Sp_Lien
            ReDim Preserve TabVariable(1 To 2, 1 To UBound(TabVariable, 2) + 1)
 
            TabVariable(1, UBound(TabVariable, 2)) = rs!Lien
            TabVariable(2, UBound(TabVariable, 2)) = i
 
        End If
        rs.MoveNext
    Next i
    Set rs = Nothing
 
End Sub

Cdlt

**possible924** · 29/08/2019, 21h12

Merci pour ta réponse
Voilà ce que j'ai fait :

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
On Error GoTo Suite
 
Dim RS As Object
Dim CheminLien01 As String
Dim CheminLien02 As String
Dim CheminLien03 As String
Dim CheminLien04 As String
Dim CheminLien05 As String
Dim CheminLien06 As String
Dim CheminLien07 As String
Dim CheminLien08 As String
Dim CheminLien09 As String
Dim CheminLien10 As String
Dim CheminLien11 As String
Dim CheminLien12 As String
Dim CheminLien13 As String
Dim CheminLien14 As String
Dim CheminLien15 As String
Dim CheminLien16 As String
Dim CheminLien17 As String
Dim CheminLien18 As String
Dim CheminLien19 As String
Dim CheminLien20 As String
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT T_Salariés_Pièces.Sp_Lien INTO TL_Salariés_Pièces_Contrat_Sélection FROM T_Salariés_Pièces " & _
                    "WHERE (((T_Salariés_Pièces.Sp_Sélection) = True) And ((T_Salariés_Pi?ces.Sp_Cl?_Personne_Nature) = " & CléPersonneNature & ")) " & _
                    "ORDER BY T_Salariés_Pièces.CléP_Salarié_Pièce"
 
'SELECT "monchemin" & [Sp_Lien] AS Lien INTO TL_Salarié_Pièces_Contrat_Sélection
Set RS = CurrentDb.OpenRecordset("TL_Salari?s_Pièces_Contrat_Sélection")
While Not RS.EOF 'tant que non fin liste des enregistrements
    If Not IsNull(RS.Sp_Lien) Then 'test champs Sp_Lien
       CheminLien01 = CheminContrat & RS.Sp_Lien
RS.MoveNext
       CheminLien02 = CheminContrat & RS.Sp_Lien
RS.MoveNext
       CheminLien03 = CheminContrat & RS.Sp_Lien
RS.MoveNext
       CheminLien04 = CheminContrat & RS.Sp_Lien
RS.MoveNext
       CheminLien05 = CheminContrat & RS.Sp_Lien
RS.MoveNext
       CheminLien06 = CheminContrat & RS.Sp_Lien
'etc jusquà CheminLien20
    End If
RS.MoveNext
Suite:
Wend
RS.Close
 
        End If
End If
End Sub

ça fait le travail, mais mal, car si le système s'arrête, c'est à cause du on error goto suite !
L'objet de tout cela est d'envoyer par messagerie des pièces stockées dans un répertoire dont le nom est contenu dans une table.
Mais le While fonctionne mal
bonne soirée
A+

**Thierry_PALLIER** · 30/08/2019, 07h45

Bonjour.

Attention aux accents et "?"

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
Sub ess2()
    Dim i As Byte
    Dim TabVariable As Variant
    Dim Rs As DAO.Recordset
    Dim CheminContrat As String
    Dim CléPersonneNature As Integer
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT T_Salariés_Pièces.Sp_Lien INTO TL_Salariés_Pièces_Contrat_Sélection FROM T_Salariés_Pièces " & _
                 "WHERE (((T_Salariés_Pièces.Sp_Sélection) = True) And ((T_Salariés_Pi?ces.Sp_Cl?_Personne_Nature) = " & CléPersonneNature & ")) " & _
                 "ORDER BY T_Salariés_Pièces.CléP_Salarié_Pièce"
 
    Set Rs = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
    Rs.MoveLast
    Rs.MoveFirst
 
    ReDim TabVariable(1 To 2, 1 To 1) As String
 
    TabVariable(1, 1) = "Lien"
    TabVariable(2, 1) = "numero"
 
    For i = 1 To Rs.RecordCount
 
        If Not IsNull(Rs!Lien) Then    'test champs Sp_Lien
            ReDim Preserve TabVariable(1 To 2, 1 To UBound(TabVariable, 2) + 1)
 
            TabVariable(1, UBound(TabVariable, 2)) = CheminContrat & Rs!Lien
            TabVariable(2, UBound(TabVariable, 2)) = i
 
        End If
        Rs.MoveNext
    Next i
 
    Set Rs = Nothing
 
End Sub

20 lignes de moins !

Reste à voir comment tu utilises ces variables.
Cdlt

**possible924** · 30/08/2019, 13h00

Merci pour la réponse

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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
Option Compare Database
Option Explicit
    Dim i As Byte
    Dim TabVariable As Variant
    Dim Rs As DAO.Recordset
    Dim MonCheminLien As String
    Dim CheminContrat As String
    Dim CléPersonneNature As Integer
Private Sub EnvoiMail_Click()
'On Error GoTo Suite:
    DoCmd.RunCommand acCmdSaveRecord
    If DCount("CléP_Salarié_Pièce", "T_Salariés_Pièces", "Sp_Sélection = " & -1) < 1 Then
        MsgBox "Il n'y a aucun document sélectionné pour l'envoi !", vbExclamation, CurrentDb.Properties("AppTitle")
    Else
        If MsgBox("Vous allez envoyer les " & DCount("CléP_Salarié_Pièce", "T_Salariés_Pièces", "Sp_Sélection = " & -1) & " documents sélectionnés" & (vbCrLf) & (vbCrLf) & _
                "Confirmez vous cet envoi ?", vbYesNo, CurrentDb.Properties("AppTitle")) = 6 Then
Dim Sender As String
Dim Recipient As String
Dim Subject As String
Dim Bcc As String
Dim BodyText As String
 
    Subject = InputBox("Objet du message", CurrentDb.Properties("AppTitle"))
    BodyText = InputBox("Corps du message", CurrentDb.Properties("AppTitle"))
 
Dim Rs As Object
Dim CheminLien01 As String
Dim CheminLien02 As String
Dim CheminLien03 As String
Dim CheminLien04 As String
Dim CheminLien05 As String
Dim CheminLien06 As String
Dim CheminLien07 As String
Dim CheminLien08 As String
Dim CheminLien09 As String
Dim CheminLien10 As String
Dim CheminLien11 As String
Dim CheminLien12 As String
Dim CheminLien13 As String
Dim CheminLien14 As String
Dim CheminLien15 As String
Dim CheminLien16 As String
Dim CheminLien17 As String
Dim CheminLien18 As String
Dim CheminLien19 As String
Dim CheminLien20 As String
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT T_Salariés_Pièces.Sp_Lien INTO TL_Salariés_Pièces_Contrat_Sélection FROM T_Salariés_Pièces " & _
                    "WHERE (((T_Salariés_Pièces.Sp_Sélection) = True) And ((T_Salariés_Pièces.Sp_Clé_Personne_Nature) = " & CléPersonneNature & ")) " & _
                    "ORDER BY T_Salariés_Pièces.CléP_Salarié_Pièce"
    DoCmd.SetWarnings True
 
'Nouveau ---------------------------------------------------------------------
 
Set Rs = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
    Rs.MoveLast
    Rs.MoveFirst
 
    ReDim TabVariable(1 To 2, 1 To 1) As String
 
    TabVariable(1, 1) = "Lien"
    TabVariable(2, 1) = "numero"
 
    For i = 1 To Rs.RecordCount
 
        If Not IsNull(Rs.Sp_Lien) Then    'test champs Sp_Lien
            ReDim Preserve TabVariable(1 To 2, 1 To UBound(TabVariable, 2) + 1)
 
            TabVariable(1, UBound(TabVariable, 2)) = CheminContrat & Rs.Sp_Lien
            TabVariable(2, UBound(TabVariable, 2)) = i
 
        End If
        Rs.MoveNext
    Next i
 
    Set Rs = Nothing
'Nouveau Fin ------------------------------------------------------------------
 
Suite:
    DoCmd.SetWarnings True
    Sender = DFirst("Cst_Email_Expéditeur", "T_Constantes")
    Recipient = DFirst("Cst_Compta_Messagerie", "T_Constantes")
 
    'Envoie l'Email avec les pièces jointes
    Dim Cdo_Message As New cdo.Message
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
 
    With Cdo_Message
        .From = Sender
        .To = Recipient
        .Subject = Subject
        .Bcc = Bcc
        .TextBody = BodyText
        .AddAttachment CheminLien01
        .AddAttachment CheminLien02
        .AddAttachment CheminLien03
        .AddAttachment CheminLien04
        .AddAttachment CheminLien05
        .AddAttachment CheminLien06
        .AddAttachment CheminLien07
        .AddAttachment CheminLien08
        .AddAttachment CheminLien09
        .AddAttachment CheminLien10
        .AddAttachment CheminLien11
        .AddAttachment CheminLien12
        .AddAttachment CheminLien13
        .AddAttachment CheminLien14
        .AddAttachment CheminLien15
        .AddAttachment CheminLien16
        .AddAttachment CheminLien17
        .AddAttachment CheminLien18
        .AddAttachment CheminLien19
        .AddAttachment CheminLien20
        .Send
    End With
    Set Cdo_Message = Nothing
    MsgBox "C'est parti !"
        End If
End If
End Sub

Voilà ce que j'ai fait, mais je n'ai aucune pièce qui part avec l'email !
A+
Pierre

**Thierry_PALLIER** · 30/08/2019, 13h33

Avec le code complet, c'est mieux.

_ les lignes 27 à 46 ne servent plus.
_ les 95 à 114 à modifier par :

Code :

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

1
2
3
4
For i = 2 To UBound(TabVariable, 2)
 
        .AddAttachment = .AddAttachment & TabVariable(1, i) & ";"
        Next i

code complet:

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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
Option Compare Database
Option Explicit
    Dim i As Byte
    Dim TabVariable As Variant
    Dim Rs As DAO.Recordset
    Dim MonCheminLien As String
    Dim CheminContrat As String
    Dim CléPersonneNature As Integer
Private Sub EnvoiMail_Click()
'On Error GoTo Suite:
    DoCmd.RunCommand acCmdSaveRecord
    If DCount("CléP_Salarié_Pièce", "T_Salariés_Pièces", "Sp_Sélection = " & -1) < 1 Then
        MsgBox "Il n'y a aucun document sélectionné pour l'envoi !", vbExclamation, CurrentDb.Properties("AppTitle")
    Else
        If MsgBox("Vous allez envoyer les " & DCount("CléP_Salarié_Pièce", "T_Salariés_Pièces", "Sp_Sélection = " & -1) & " documents sélectionnés" & (vbCrLf) & (vbCrLf) & _
                "Confirmez vous cet envoi ?", vbYesNo, CurrentDb.Properties("AppTitle")) = 6 Then
Dim Sender As String
Dim Recipient As String
Dim Subject As String
Dim Bcc As String
Dim BodyText As String
 
    Subject = InputBox("Objet du message", CurrentDb.Properties("AppTitle"))
    BodyText = InputBox("Corps du message", CurrentDb.Properties("AppTitle"))
 
Dim Rs As Object
 
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT T_Salariés_Pièces.Sp_Lien INTO TL_Salariés_Pièces_Contrat_Sélection FROM T_Salariés_Pièces " & _
                    "WHERE (((T_Salariés_Pièces.Sp_Sélection) = True) And ((T_Salariés_Pièces.Sp_Clé_Personne_Nature) = " & CléPersonneNature & ")) " & _
                    "ORDER BY T_Salariés_Pièces.CléP_Salarié_Pièce"
    DoCmd.SetWarnings True
 
'Nouveau ---------------------------------------------------------------------
 
Set Rs = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
    Rs.MoveLast
    Rs.MoveFirst
 
    ReDim TabVariable(1 To 2, 1 To 1) As String
 
    TabVariable(1, 1) = "Lien"
    TabVariable(2, 1) = "numero"
 
    For i = 1 To Rs.RecordCount
 
        If Not IsNull(Rs.Sp_Lien) Then    'test champs Sp_Lien
            ReDim Preserve TabVariable(1 To 2, 1 To UBound(TabVariable, 2) + 1)
 
            TabVariable(1, UBound(TabVariable, 2)) = CheminContrat & Rs.Sp_Lien
            TabVariable(2, UBound(TabVariable, 2)) = i
 
        End If
        Rs.MoveNext
    Next i
 
    Set Rs = Nothing
'Nouveau Fin ------------------------------------------------------------------
 
Suite:
    DoCmd.SetWarnings True
    Sender = DFirst("Cst_Email_Expéditeur", "T_Constantes")
    Recipient = DFirst("Cst_Compta_Messagerie", "T_Constantes")
 
    'Envoie l'Email avec les pièces jointes
    Dim Cdo_Message As New cdo.message
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
    Dim Attache As String
 
 
    With Cdo_Message
        .From = Sender
        .To = Recipient
        .Subject = Subject
        .Bcc = Bcc
        .TextBody = BodyText
 
        For i = 2 To UBound(TabVariable, 2)
 
        .AddAttachment = .AddAttachment & TabVariable(1, i) & ";"
        Next i
 
 
        .Send
    End With
    Set Cdo_Message = Nothing
    MsgBox "C'est parti !"
        End If
End If
End Sub

pas tester mais celà devrait marcher.

**possible924** · 30/08/2019, 14h48

Re bonjour,
A la ligne 69,

Code :

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

    Dim Attache As String

je ne vois pas à quoi sert cette variable
et ça bloque à la ligne 81

Code :

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

        .AddAttachment = .AddAttachment & TabVariable(1, i) & ";"

J'obtiens le message d'erreur "argument non facultatif "

A+
Pierre

**Thierry_PALLIER** · 30/08/2019, 15h34

la ligne mentionnée (n°69) ne sert pas.
Je voulais mettre les pièces jointes dedans mais celà aurait sans doutes fait trop de caractères.

Code :

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

1
2
3
4
.AddAttachment  Nz(.AddAttachment,"") & TabVariable(1, i) & ";"
'sans le =
 'si il manque des guillemets
.AddAttachment = Nz(.AddAttachment,"") & Chr(34) & TabVariable(1, i) & Chr(34) & ";"

et enfin, si le ";" pose problème arrivé à la dernière piece jointe:

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
            With Cdo_Message
                .From = Sender
                .To = Recipient
                .Subject = Subject
                .Bcc = Bcc
                .TextBody = BodyText
 
                For i = 2 To UBound(TabVariable, 2)
 
                    If i = UBound(TabVariable, 2) Then
                        .AddAttachment Nz(.AddAttachment, "") & TabVariable(1, i)
                    Else
                        .AddAttachment Nz(.AddAttachment, "") & TabVariable(1, i) & ";"
                    End If
 
                Next i
 
 
                .Send
            End With

**Thumb down** · 30/08/2019, 15h46

bonjour,

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
Option Compare DatabaseOption Explicit
    Dim i As Byte
    Dim TabVariable As Variant
    Dim Rs As DAO.Recordset
    Dim MonCheminLien As String
    Dim CheminContrat As String
    Dim CléPersonneNature As Integer
    Dim PièceJointe As String
Private Sub EnvoiMail_Click()
Set Rs = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Contrat_Sélection")
While Not Rs.EOF 'tant que non fin liste des enregistrements
    If CStr("" & Rs.Lien) <> "" Then 'test champs Sp_Lien
       PièceJointe = PièceJointe & CheminContrat & Rs.Sp_Lien & ";"
    End If
    Rs.MoveNext
Wend
Sender = DFirst("Cst_Email_Expéditeur", "T_Constantes")
Subject = InputBox("Objet du message", CurrentDb.Properties("AppTitle"))
BodyText = InputBox("Corps du message", CurrentDb.Properties("AppTitle"))
Recipient = DFirst("Cst_Compta_Messagerie", "T_Constantes")
Mail Sender, Subject, BodyText, Recipient, Pj:=PièceJointe
End Sub
Sub Mail(From As String, Sujet As String, Message As String, Destinataire As String, Optional DestinataireCopy As String, Optional DestinataireCopyCacher As String, Optional Pj As String = "")
Set objOutlook = CreateObject("Outlook.application")
Set MailObj = objOutlook.CreateItem(olMailItem)
With MailObj
    .From = From
    .To = Destinataire
    .CC = DestinataireCopy
    .Bcc = DestinataireCopyCacher
    .Subject = Sujet
    .BodyFormat = 2
    .HTMLBody = Replace(Message, Chr(10), "<br>")
    If Trim("" & Pj) <> "" Then
        p = Split(Pj & ";", ";")
        For i = 0 To UBound(p)
            If Trim("" & p(i)) <> "" Then .Attachments.Add Trim("" & p(i))
        Next
    End If
    '.Display 'Can be .Send but prompts for user intervention before sending without 3rd party software like ClickYes
    .Send
End With
End Sub

**possible924** · 30/08/2019, 17h39

Le .AddAttachment ne passe pas !

**Thumb down** · 30/08/2019, 18h03

Envoyé par possible924

Le .AddAttachment ne passe pas !

je ne sais pas si tu t'adresse à moi, dans le doute je répons!

voila ce que j'ai publié en 2014 et que utilises dans mes code; l'attachement des pièces jointe fonctionne.

https://www.developpez.net/forums/d1...t/#post7968025

**possible924** · 31/08/2019, 07h34

Bonjour à tous,
Le message "Le .AddAttachment ne passe pas !" s'adressait à Thierry_PALLIER

Hier, j'ai galéré toute la journée sans aboutir à une solution satisfaisante
La seule chose que j'ai réussi à faire fonctionner est la suivante qui fonction grâce à "On Error GoTo Suite"
Ce n'est pas très élégant, ça fait beaucoup de ligne, mais ça fonctionne et nécessité fait loi !
Ce que j'ai fait est peut être un peu primaire, mais je suis prêt à recevoir d'autres suggestions que je puisse réussir à mettre en œuvre
Merci pour votre aide
Pierre

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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
Option Compare Database
Option Explicit
Dim MonCheminLien As String
Dim CheminContrat As String
Dim CléPersonneNature As Long
 
Private Sub EnvoiMail_Click()
On Error GoTo Suite
 
    If DCount("CléP_Salarié_Pièce", "T_Salariés_Pièces", "Sp_Sélection = " & -1) < 1 Then
        MsgBox "Il n'y a aucun document sélectionné pour l'envoi !", vbExclamation, CurrentDb.Properties("AppTitle")
    Else
        If MsgBox("Vous allez envoyer les " & DCount("CléP_Salarié_Pièce", "T_Salariés_Pièces", "Sp_Sélection = " & -1) & " documents sélectionnés" & (vbCrLf) & (vbCrLf) & _
                "Confirmez vous cet envoi ?", vbYesNo, CurrentDb.Properties("AppTitle")) = 6 Then
 
    DoCmd.SetWarnings False
    DoCmd.RunSQL "SELECT T_Salariés_Pièces.Sp_Lien INTO TL_Salariés_Pièces_Sélection FROM T_Salariés_Pièces " & _
                    "WHERE (((T_Salariés_Pièces.Sp_Lien) Is Not Null) AND ((T_Salariés_Pièces.Sp_Sélection)=True) AND ((T_Salariés_Pièces.Sp_Clé_Personne_Nature)= " & CléPersonneNature & ")) " & _
                    "ORDER BY T_Salariés_Pièces.CléP_Salarié_Pièce"
    DoCmd.SetWarnings True
 
Dim RS As Object
Set RS = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Sélection")
While Not RS.EOF 'tant que non fin liste des enregistrements
    If Not IsNull(RS.Sp_Lien) Then 'test champs Sp_Lien
        Dim CheminLien01 As String
        CheminLien01 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien02 As String
        CheminLien02 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien03 As String
        CheminLien03 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien04 As String
        CheminLien04 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien05 As String
        CheminLien05 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien06 As String
        CheminLien06 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien07 As String
        CheminLien07 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien08 As String
        CheminLien08 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien09 As String
        CheminLien09 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien10 As String
        CheminLien10 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien11 As String
        CheminLien11 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien12 As String
        CheminLien12 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien13 As String
        CheminLien13 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien14 As String
        CheminLien14 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien15 As String
        CheminLien15 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien16 As String
        CheminLien16 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien17 As String
        CheminLien17 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien18 As String
        CheminLien18 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien19 As String
        CheminLien19 = CheminContrat & RS.Sp_Lien
RS.MoveNext
        Dim CheminLien20 As String
        CheminLien20 = CheminContrat & RS.Sp_Lien
    End If
Suite:
Wend
RS.Close
 
    DoCmd.DeleteObject acTable, "TL_Salariés_Pièces_Sélection"
 
Dim Sender As String
Dim Recipient As String
Dim Bcc As String
Dim Subject As String
Dim BodyText As String
 
    Sender = DFirst("Cst_Email_Expéditeur", "T_Constantes")
    Recipient = DFirst("Cst_Compta_Messagerie", "T_Constantes")
    Bcc = DFirst("Cst_Email_Expéditeur_PourCopie", "T_Constantes")
    Subject = InputBox("Objet du message", CurrentDb.Properties("AppTitle"))
    BodyText = InputBox("Corps du message", CurrentDb.Properties("AppTitle"))
 
    'Envoie l'Email avec les pièces jointes
    Dim Cdo_Message As New cdo.Message
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
 
    With Cdo_Message
        .From = Sender
        .To = Recipient
        .Bcc = Bcc
        .Subject = Subject
        .TextBody = BodyText
        .AddAttachment CheminLien01
        .AddAttachment CheminLien02
        .AddAttachment CheminLien03
        .AddAttachment CheminLien04
        .AddAttachment CheminLien05
        .AddAttachment CheminLien06
        .AddAttachment CheminLien07
        .AddAttachment CheminLien08
        .AddAttachment CheminLien09
        .AddAttachment CheminLien10
        .AddAttachment CheminLien11
        .AddAttachment CheminLien12
        .AddAttachment CheminLien13
        .AddAttachment CheminLien14
        .AddAttachment CheminLien15
        .AddAttachment CheminLien16
        .AddAttachment CheminLien17
        .AddAttachment CheminLien18
        .AddAttachment CheminLien19
        .AddAttachment CheminLien20
        .Send
    End With
    Set Cdo_Message = Nothing
    MsgBox "C'est parti !"
        End If
End If
End Sub

**Thumb down** · 01/09/2019, 13h16

Bonjour,
déjà supprime le on error, tu n'en as pas besoin!

dans ton code tu remplace ça

Code :

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

1
2
3
4
5
6
7
8
While Not RS.EOF 'tant que non fin liste des enregistrements
    If Not IsNull(RS.Sp_Lien) Then 'test champs Sp_Lien
        Dim CheminLien01 As String
        CheminLien01 = CheminContrat & RS.Sp_Lien
RS.MoveNext
etc...
Wend
RS.Close

par ça

Code :

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

1
2
3
4
5
6
7
8
9
Dim RS As Object
Set RS = CurrentDb.OpenRecordset("TL_Salariés_Pièces_Sélection")
While Not RS.EOF 'tant que non fin liste des enregistrements
    If Not CStr("" & RS.Sp_Lien) = "" Then 'test champs Sp_Lien
    If Dir(CheminContrat & RS.Sp_Lien) <> "" Then MonCheminLien = MonCheminLien & CheminContrat & RS.Sp_Lien & ";"
      End If
RS.MoveNext
       Wend
RS.Close

modifies ça

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
 With Cdo_Message
        .From = Sender
        .To = Recipient
        .Bcc = Bcc
        .Subject = Subject
        .TextBody = BodyText
        .AddAttachment CheminLien01
        .AddAttachment CheminLien02
        .AddAttachment CheminLien03
        .AddAttachment CheminLien04
        .AddAttachment CheminLien05
        .AddAttachment CheminLien06
        .AddAttachment CheminLien07
        .AddAttachment CheminLien08
        .AddAttachment CheminLien09
        .AddAttachment CheminLien10
        .AddAttachment CheminLien11
        .AddAttachment CheminLien12
        .AddAttachment CheminLien13
        .AddAttachment CheminLien14
        .AddAttachment CheminLien15
        .AddAttachment CheminLien16
        .AddAttachment CheminLien17
        .AddAttachment CheminLien18
        .AddAttachment CheminLien19
        .AddAttachment CheminLien20
        .Send     End With

comme ça

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
With Cdo_Message        
        .To = Recipient
        .Bcc = Bcc
        .Subject = Subject
        .TextBody = BodyText
        splitPj = Split(MonCheminLien & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
            End If
        Next
        .Send
    End With

**possible924** · 01/09/2019, 15h22

Je viens de faire les remplacements
sur :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
With Cdo_Message        
        .To = Recipient
        .Bcc = Bcc
        .Subject = Subject
        .TextBody = BodyText
        splitPj = Split(MonCheminLien & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
            End If
        Next

J'obtiens pour splitPj et IsplitPj "Variable non définie"
J'ai fait ça :

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
Dim splitPj As String
Dim isplitpj As String
 
With Cdo_Message
        .To = Recipient
        .Bcc = Bcc
        .Subject = Subject
        .TextBody = BodyText
        splitPj = Split(MonCheminLien & ";", ";")
 
        For isplitpj = 0 To UBound(splitPj)
            If Trim("" & splitPj(isplitpj)) <> "" Then
                .AddAttachment Trim("" & splitPj(isplitpj))
            End If
        Next
        .Send
End With

J'otbiens sur UBound(splitPj) le message "Tableau attendu"
et ça s'arrête là !

**Thumb down** · 01/09/2019, 16h34

désolé

Code :

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

1
2
Dim splitPj() As String
Dim IsplitPj  As Integer

While ne fonctionne pas

VBA Access

Discussions similaires

Partager

Partager