Envoyer plusieurs pièces jointes

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

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, 23h05

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, 23h50

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é · 09/06/2014, 00h07

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, 07h47

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, 15h45

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

**grisan29** · 13/06/2014, 22h23

bonjour rdurupt

comment puis remplacer

Code :

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

1
2
3
Private Sub UserForm_Initialize()
Me.WebBrowser1.Navigate (ActiveWorkbook.Path & "\WisiWig\index.html")
End Sub

pour que je mette WisiWig sur c: et voir ce que tu a fait

car tel que c'est sur

Code :

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

c:\users\utilisateur\AppData\Local\temp\wz7b38\mailer

que ç’a cherche et bug

Pascal

Invité · 13/06/2014, 22h56

Il faut deziper tout le répertoir maileur sur ton disque dur

**grisan29** · 14/06/2014, 08h39

bonjour rdurupt

merci pour ce fichier a base de webbrother mais bug a l'envoi d'un mail peut etre du au panneau qui s'ouvre et qui est le même que sur l’aperçu joint
bug a la première ligne de

Code :

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

1
2
3
4
5
6
7
 
Private Sub envoyer_Click()
 
 Me.WebBrowser1.document.Script.execScript "OnClikDetail();"
 corp_du_message = Me.WebBrowser1.document.getElementById("input").Value
 Me.WebBrowser1.document.Script.execScript "OnClikDetail();"
End Sub

voici l'apercu
Pièce jointe 148633

autrement comment fonctionne une webbrother

Pascal

Invité · 14/06/2014, 16h44

vue que pour l'instant ton problème est lier aux pièces jointes on regardera ça plus tard si l'option t'intéresse!

**grisan29** · 14/06/2014, 21h25

bonsoir Rdurupt

Merci beaucoup pour ce fichier modifier comme il faut ,

il envoi plusieurs pièces jointes,je me suis envoyé un mail pour le savoir

mais pourquoi avoir supprimer le bouton devis et de toutes façon le bouton facture ne mets pas la pièce dans la listbox
est ce que le bouton " autres emplacements " sera a supprimer au vu de ce que tu a fait

Pascal

Invité · 14/06/2014, 22h08

J'ai n'ai rien voulu supprimer une fauce manip je ne voie que ça je regarde

Invité · 15/06/2014, 16h56

Bonjour,

**grisan29** · 15/06/2014, 22h53

bonsoir rdurupt

merci pour cette version a laquelle je ne comprends pas le fonctionnement du bouton zipper qui va chercher sur le pc quelque chose mais est-ce un fichier a zipper pour joindre après ??
et pourquoi il y 2 boutons dont 1 pour supprimer pièces jointes et un autre pour la retirer
le module zipeurRD est vide de code

j'aime bien ta version a base de webrother et je n'ai plus le panneau d'avertissement

Pascal

Invité · 16/06/2014, 10h22

dans la version originale, il y avait le bouton [supprimer pièces jointes ] qui supprimait physiquement la pièce jointe du disque dur! je n'ai pas compris l’intérêt mai bon je l'ai gardé et adapté à la notion de liste.
vue que maintenant nous avons une liste pour les pièces jointes [Retirer pièce jointe] permet de supprimer de la liste un fichier en le sélectionnant au préalable dans la liste. ce bouton n'a pas la même fonction que [supprimer pièces jointes ].
[Zipper les pièces jointes] permet de zipper toutes le pièces jointes dans un fichier Zip. la fonction zipper ne vas rien chercher mais te propose de saisire le nom du fichier ZIP.
le module zipeurRD fait parie d'une collection de bibliothèque de fonction dont je dispose je l'ai importé dans le projet vb puis copié son contenu dans le module de classe EFFET_waow_bouton qui l'utilise, en effet j’aurai due le supprimer.

en ce qui concerne le WisiWig faisons déjà fonctionner en l'état on y reviendra.

**grisan29** · 16/06/2014, 13h57

bonjour rdurupt

merci pour cette version avec laquelle je ne reçois pas de récépisser, je ne sais pas où est envoyer le mail mais il n'arrive pas a destination

Pascal

Invité · 16/06/2014, 14h13

je ne comprend pas???
sauf pour la gestion des pièces jointe je n'est rien changé!

**grisan29** · 16/06/2014, 22h31

bonjour rdurupt
j'ai pas vu ta réponse avant de partir, et du coup j'ai retélécharger ton exemple et fait un essai parfait, le mail envoyer m'a bien été envoyer de suite et chose bizarre l'autre mail que j'ai envoyer a midi m'est arrivé vers 14h, c'est pour cela que je t'ai répondu comme cela

en fait ton fichier fonctionne bien

cela fonctionne bien maintenant ,

pas de bug rien du tout

Merci a toi
mis en résolu par modérateur
Pascal

**patricktoulon** · 11/08/2015, 00h53

bonsoir

je vois que mon maileur a fait du chemin, sachez tout de meme qu'il y a eu plusieures versions qui en ont découlé certaines d'entre elles gerent le multi pieces jointes

soyez patient ces jours ci une newversion arrive avec encore plus de surprise

mais je dois reconnaitre que cette version est utilisée dans mon app pro

soyez patients je réserve des surprises

merci de faire vivre mon fichier
bonne utilisation

Envoyer plusieurs pièces jointes [XL-2013]

Macros et VBA Excel

Discussions similaires

Partager

Partager