Discussion :

[olivepao]

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