Envoyer plusieurs pièces jointes

**grisan29** · 08/06/2014, 21h34

bonjour a vous tous
dans la discussion que rdurupt a bien menée
serai t-il possible de pouvoir également envoyer plusieurs pièces jointes au fichier d'envoi de mails de patricktoulon légèrement modifié pour intégré cc; cci et recu d'envoi mais qui ne fonctionne pas avec outlook
http://cjoint.com/?DFivOasr8E1 je suis obliger de passer par cjoint car xlsm est refusé en pièces jointes
merci par avance de ce que vous pourriez faire

Pascal

Invité · 08/06/2014, 22h05

zip le XLSM
dans le même esprit

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
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
const SSL=false
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 'Success, failure or delay
Public Function MailEnvoi(Serveur, Identify, SSL, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, DestEnCah, Objet, Body, Pj)
On Error Resume Next
MailEnvoi = True
Dim Log
Dim I
' sub pour envoyer les mails
Dim msg
Dim Conf
Dim Config
Dim ess
Dim splitPj
Dim IsplitPj
Dim schema
Const cdoBasic = 1
 
Set msg = CreateObject("CDO.Message") 'pour la configuration du message
Set Conf = CreateObject("CDO.Configuration") '  pour la configuration de l'envoi
Dim strHTML
 
Set Config = Conf.Fields
 
' Configuration des parametres d'envoi
'(SMTP - Identification - SSL - Password - Nom Utilisateur - Adresse messagerie)
schema = "http://schemas.microsoft.com/cdo/configuration/" 'smtpusessl
With Config
 
If Identify <> 0 Then
    .Item(schema & "smtpusessl") = SSL
    .Item(schema & "smtpusetls") = 1
    .Item(schema & "smtpauthenticate") = Identify
    .Item(schema & "sendusername") = User
    .Item(schema & "sendpassword") = PassWord
End If
    .Item(schema & "smtpserverport") = Port
    .Item(schema & "sendusing") = 2
    .Item(schema & "smtpserver") = Serveur
    .Item(schema & "smtpconnectiontimeout") = Delay
    .Item(schema & "enablessl") = 1
 
    .Update
End With
'Configuration du message
'If E_mail.Sign.Value = Checked Then Convert ServeurFrm.SignTXT, ServeurFrm.Text1
 
With msg
    Set .Configuration = Conf
 
    .To = Dest
    .cc = DestEnCopy
    .bcc = Expediteur & DestEnCah
    .FROM = Expediteur
    .Subject = Objet
'   .DSNOptions = cdoDSN
'
 
    .htmlbody = Replace(Replace(Body, Chr(13), "", 1, -1), Chr(10), "<br>", 1, -1) '"<p align=""center""><font face=""Verdana"" size=""1"" color=""#9224FF""><b><br><font face=""Comic Sans MS"" size=""5"" color=""#FF0000""></b><i>" & body & "</i></font> " 'E_mail.ZThtml.Text
            If Pj <> "" Then
        splitPj = Split(Pj & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
                If Err <> 0 Then
                    MailEnvoi = False
                    Exit Function
                End If
            End If
        Next
 
    End If
 
    .Send 'envoi du message
    If Err <> 0 Then
           MailEnvoi = False
    Else
           MailEnvoi = True
    End If
 
On Error GoTo 0
End With
 
Set msg = Nothing
Set Conf = Nothing
Set Config = Nothing
 
End Function

**grisan29** · 08/06/2014, 22h50

Bonsoir rdurupt

waouh, ça c'est un bloc de code que je ne sais pas ou mettre dans le fichier joint, où comment le séparer pour y arriver
bon je l'ai mis dans un module et je regarderai d'un peu plus près demain dans l’après midi

Pascal

Invité · 08/06/2014, 23h07

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
Sub test()
'Serveur SMTP,Idetifian=true, SSl=true,,User,paswprd, port, delay=10...
MailEnvoi "smtp.googlemail.com", True, True, "User@gmail.com", "PassWord", 465, 10, "Expediteur@gmail.com", "Dest@gmail.com", "DestEnCopy@gmail.com", "DestEnCaht@gmail.com", "Sujet", "messaage", "c:\test\test.xls;c:\test\test2.xls"
End Sub
 
Public Function MailEnvoi(Serveur, Identify, SSL, User, PassWord, Port, Delay, Expediteur, Dest, DestEnCopy, DestEnCah, Objet, Body, Pj)
On Error Resume Next
MailEnvoi = True
Dim Log
Dim I
' sub pour envoyer les mails
Dim msg
Dim Conf
Dim Config
Dim ess
Dim splitPj
Dim IsplitPj
Dim schema
Const cdoBasic = 1
 
Set msg = CreateObject("CDO.Message") 'pour la configuration du message
Set Conf = CreateObject("CDO.Configuration") '  pour la configuration de l'envoi
Dim strHTML
 
Set Config = Conf.Fields
 
' Configuration des parametres d'envoi
'(SMTP - Identification - SSL - Password - Nom Utilisateur - Adresse messagerie)
schema = "http://schemas.microsoft.com/cdo/configuration/" 'smtpusessl
With Config
 
If Identify <> 0 Then
    .Item(schema & "smtpusessl") = SSL
    .Item(schema & "smtpusetls") = 1
    .Item(schema & "smtpauthenticate") = Identify
    .Item(schema & "sendusername") = User
    .Item(schema & "sendpassword") = PassWord
End If
    .Item(schema & "smtpserverport") = Port
    .Item(schema & "sendusing") = 2
    .Item(schema & "smtpserver") = Serveur
    .Item(schema & "smtpconnectiontimeout") = Delay
    .Item(schema & "enablessl") = 1
 
    .Update
End With
'Configuration du message
'If E_mail.Sign.Value = Checked Then Convert ServeurFrm.SignTXT, ServeurFrm.Text1
 
With msg
    Set .Configuration = Conf
 
    .To = Dest
    .cc = DestEnCopy
    .bcc = Expediteur & DestEnCah
    .FROM = Expediteur
    .Subject = Objet
'   .DSNOptions = cdoDSN
'
 
    .htmlbody = Replace(Replace(Body, Chr(13), "", 1, -1), Chr(10), "<br>", 1, -1) '"<p align=""center""><font face=""Verdana"" size=""1"" color=""#9224FF""><b><br><font face=""Comic Sans MS"" size=""5"" color=""#FF0000""></b><i>" & body & "</i></font> " 'E_mail.ZThtml.Text
            If Pj <> "" Then
        splitPj = Split(Pj & ";", ";")
 
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then
                .AddAttachment Trim("" & splitPj(IsplitPj))
                If Err <> 0 Then
                    MailEnvoi = False
                    Exit Function
                End If
            End If
        Next
 
    End If
 
    .Send 'envoi du message
    If Err <> 0 Then
           MailEnvoi = False
    Else
           MailEnvoi = True
    End If
 
On Error GoTo 0
End With
 
Set msg = Nothing
Set Conf = Nothing
Set Config = Nothing
 
End Function

palace un ; de séparation entre lest fichets

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
Sub EnvoiMail_CDO()
serveur = Sheets("acceuil").Range("D2").Value
Dim iMsg As Object, iConf As Object, Flds As Object
Set iMsg = CreateObject("cdo.message")
Set iConf = CreateObject("cdo.configuration")

Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'remplacez "smtp.nomserveur.fr" par le nom de serveur de votre FAI :
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serveur
.Update
End With

With iMsg
Set .Configuration = iConf
.BodyPart.Charset = "utf-8"
.To = form_email.destinataire.Value
.CC = form_email.CC.Value
If form_email.CCI.Value = "" Then
.BCC = "popeye@epinard.fr" ' changer popeye avec votre adresse
Else:
.BCC = form_email.CCI.Value & ";" & "popeye@epinard.fr" ' changer popeye avec votre adresse
End If
.From = form_email.Emetteur
.Subject = form_email.titre
.HTMLBody = paragraphe
If form_email.piece_jointe <> "" Then
        splitPj = Split(form_email.piece_jointe & ";", ";")
        For IsplitPj = 0 To UBound(splitPj)
            If Trim("" & splitPj(IsplitPj)) <> "" Then .AddAttachment Trim("" & splitPj(IsplitPj))
        Next
End If
.Send
End With
If form_email.piece_jointe <> "" Then
fichier = form_email.piece_jointe.Value
'Kill fichier
form_email.piece_jointe = ""
End If
End Sub

**grisan29** · 09/06/2014, 06h47

bonjour rdurupt

merci du code mais il fait exactement comme avant l'ajout d'une seconde pièces écrase la 1ère, même en ayant mis un ";" derrière la 1ére

bonne journée

Pascal

Invité · 13/06/2014, 14h45

j'ai apporté quelques modification DéZip tout le répertoire sur ton disque dur!

Envoyer plusieurs pièces jointes [XL-2013]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager