Bonjour tout le monde
Je rencontre un petit problème pour l'envoi multiutilisateurs de fichiers (plusieurs) avec Excel.
Premièrement, je suis sous Windows 10 et Office 365.
J'arrive, dans un premier temps, avec ma macro (Module 2) à ouvrir l'explorateur afin de sélectionner les fichiers que je désire mettre en pièces jointes.
J'arrive également à sélectionner les adresses mail figurant sur la feuille.
Lorsque je valide, le courriel s'affiche avec les destinataires mais les pièces jointes ne sont pas jointes.
J'ai effectué de nombreuses recherches mais je sèche depuis quelques jours afin de trouver une solution.
Je vous remercie, par avance de votre précieuse aide.
Je joints le code et le fichier.
PS : Prenez votre temps, car avec mes horaires de ouf, je ne pense pas pouvoir revenir d'ici le week-end prochain.
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 Sub Envoidoc() ' Envoi courriel multidestinataires avec documents Dim OTApp As Object Dim MItem As Object Dim Cellules As Range Dim Lignes As Range Dim Adr_Courriel As String Dim Txt_Texte As String Dim Nbre_Fichier As Variant ChDir "C:\" On Error Resume Next ' Fichiers à joindre Nbre_Fichier = Application.GetOpenFilename( _ Title:=" SÉLECTIONNEZ LE(S) FICHIER(S) Á JOINDRE AU COURRIEL ", _ FileFilter:="Extention de fichier,*.*", _ MultiSelect:=True) ' Nbre de fichiers joints If Not IsArray(Nbre_Fichier) Then MsgBox "AUCUN FICHIER SÉLECTIONNÉ !" Else MsgBox UBound(Nbre_Fichier) - LBound(Nbre_Fichier) + 1 _ & " FICHIER(S) SÉLECTIONNÉ(S) !" End If On Error Resume Next Txt_Texte = "Choisissez vos adresses courriel" ' Sélection des adresses courriel Set Lignes = Application.InputBox( _ Title:=" SAISIE DES ADRESSES COURRIEL", _ Prompt:=" UTILISEZ LE CLIC GAUCHE DE LA SOURIS ET LA TOUCHE CTRL DU CLAVIER ENFONCÉE ! ", _ Default:=Txt_Texte, _ Left:=500, _ Top:=500, _ Type:=8) If Lignes Is Nothing Then Exit Sub Set OTApp = CreateObject("Outlook.Application") For Each Cellules In Lignes If Cellules.Value Like "*@*" Then If Adr_Courriel = "" Then Adr_Courriel = Cellules.Value Else Adr_Courriel = Adr_Courriel & ";" & Cellules.Value End If End If Next Set MItem = OTApp.CreateItem(0) ' Remplissage du courriel With MItem .To = Adr_Courriel .Display .Attachments.Add Nbre_Fichier End With End Sub
Partager