Envoi e-mail via Excel

Version imprimable

1 pièce(s) jointe(s)

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:

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

Bonjour,

Je pense qu'une simple boucle sur le tableau Nbre_fichier fait l'affaire

dans cette partie
Code:

1 2 3 4 5 6 With MItem .To = Adr_Courriel .Display .Attachments.Add Nbre_Fichier End With
ajouter un boucle sur le tableau
Code:

1 2 3 4 5 6 7 8 With MItem .to = Adr_Courriel .Display For i = 1 To UBound(Nbre_Fichier) .Attachments.Add Nbre_Fichier(i) Next End With

22/07/2018, 14h22
olivepao

Envoi e-mail via Excel

Bonjour EJO64, bonjour tout le monde

Je viens de tester ta proposition.

Malheureusement, les fichiers ne sont toujours pas mis en pièces jointe.

J'ai essayé aussi de trouver d'autres solutions sur le net mais toujours sans succès.

Si d'autres personnes ont une ou des idées, je suis toujours preneur.

Meilleurs messages à tous.

Olivier

bonjour
je ne sais pas avec outlook mais avec cdo on peut intégré en piece jointe x fichiers sans boucle
Code:

1 2 3 4 5 6 With MItem .To = Adr_Courriel .Display .Attachments.Add Join(Nbre_Fichier, ";")'pour le separateur je ne sais pas non plus avec outlook,avec cdo c'est ";" End With

22/07/2018, 15h27
olivepao

Hello Patrick

Merci pour ta réponse mais ta proposition n'a pas d'effet.

Bonne fin de journée

Hello le forum

Petite précision à ma demande.

Avec le code ci-dessous, l'envoi d'UN SEUL fichier s'effectue !

J'ai essayer de l'adapter pour un envoi multi-fichiers mais . . .

Code:

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
 
Sub Envoidoc()
' Envoi courriel multidestinataires avec document
    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 String
 
Nbre_Fichier  = Application.GetOpenFilename(, , "Sélectionner le fichier à envoyer")
  If Nbre_Fichier  = "" Then
    MsgBox "Aucun fichier sélectionné"
    Exit Sub
  End If
 
On Error Resume Next
    Txt_Texte = "Choisissez vos 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)
With MItem 
        .To = Adr_Courriel 
        .Display
        .Attachments.Add Nbre_Fichier 
End With
End Sub

22/07/2018, 21h35
clementmarcotte

Bonjour,

Mais pourquoi t'arracher les cheveux ? Puisque tu as Office 365, tu as un compte OneDrive, dont tu peux contrôler l'accès par des étrangers. Tu mets ton fichier sur OneDrive et tu leur envoies le lien sur OneDrive. Ceux qui ont besoin du fichier pourront y accéder.

Et puis, si tous tes correspondants ont Office 365, Excel d'Office 365, et Excel 2019, un de ces jours, intègrent maintenant un tout nouveau système de partage de classeurs sur OneDrive.
22/07/2018, 22h14
olivepao

Hello Clément

Je te remercie pour ta participation.

Si tu regarde mon fichier que j'ai mis en pièce jointe (premier post), c'est un répertoire avec des adresses courriels.

Dans mon job, je dois envoyer plusieurs fois par jour des fichiers à des collaborateurs.

La procédure est ok pour le choix des collaborateurs mais pas celle permettant de joindre des fichiers.

Dans mon complément d'information que j'ai posté aujourd'hui, j'arrive à joindre un seul fichier mais pas plusieurs.

Je te souhaite une bonne fin de soirée.

Salut

La méthode Add semble attendre un fichier pas plusieurs mais par contre rien ne semble interdire de faire appel plusieurs fois à add.
Ainsi tu peux à partir de Nbr_Fichier établir un tableau à l'aide de Split, puis boucler sur chaque élément de ce tableau en appelant Add pour chacun d'eux

Un truc comme ça par exemple
Code:

1 2 3 4 5 6 7 8 9 Dim OneFile As Variant Set MItem = OTApp.CreateItem(0) With MItem .To = Adr_Courriel .Display For Each OneFile In Split(Nbre_Fichier, ";") .Attachments.Add OneFile Next End With
++
Qwaz

22/07/2018, 23h39
olivepao

Salut Qwazerty

Merci de te pencher si tard sur la question.

Je viens de tester ta proposition nocturne qui reste sans effet sur mon problème.

Je vais continuer mes recherches.

A++++
23/07/2018, 06h25
Qwazerty

Salut

As-tu bien contrôler que les nom de fichier sont déparés par des ";"?
Place un point d'arrêt sur le for et exécute en mode pas à pas pour voir si la boucle est effectuée plusieurs fois.

Si ça n'est pas le cas place un espion (ou regarder dans la fenêtre des variables locales) pour avoir le contenu de Nbre_Fichier pour regarder comment sont séparés les fichiers.

++
Qwaz

Bonjour,

Chez moi le code de EJO64 au post numéro 2 fonctionne sans souci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub aa()
Dim ObjOutlook As Object
Nbre_Fichier = Application.GetOpenFilename( _
    Title:="                                                SÉLECTIONNEZ  LE(S) FICHIER(S) Á JOINDRE AU COURRIEL ", _
    FileFilter:="Extention de fichier,*.*", _
    MultiSelect:=True)
For i = 1 To 4
debug.print Nbre_Fichier(i)
Next
Set ObjOutlook = CreateObject("outlook.application")
    Set oBjMail = ObjOutlook.CreateItem(olMailItem)
    With oBjMail
       For i = 1 To 4
        .Attachments.Add Nbre_Fichier(i)
        Next
       .Display
    End With
 
End Sub

23/07/2018, 12h21
Qwazerty

Salut

Lol... j'ai été grillé mais de plusieurs jours... j'aurais mieux dû lire toutes les réponses.
(Je vois bien que le code est différent ;) et que du coup le mien est faux! )

++
Qwaz

Hello tout le monde et surtout EJO64, patricktoulon, clementmarcotte, Qwazerty et halaster08

Suite à un "mauvais" copier-coller, le code de EJO64 ne fonctionnait pas hier.

J'ai tout repris et le code de EJO64 fonctionne.

EJO64 merci à toi. Merci également à ceux qui ont participé.

Je clôture le post !

Afin que le post soit utile à d'autres, je mets le code corrigé !

Code:

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 Sub Envoidoc() ' Envoi courriel multidestinataires avec plusieurs documents joints ' A saisir dans un module 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 For i = 1 To UBound(Nbre_Fichier) .Attachments.Add Nbre_Fichier(i) Next End With End Sub