XL 2010 Envoi groupé par outlook via VBA

[Nickal]

Bonjour,

J'ai fait il y a quelque temps une macro d'envoi via Outlook (voir pièce jointe), et j'aimerai pouvoir envoyer le classeur d'un coup à plusieurs destinataires. Le problème c'est que je ne vois pas comment faire.
De plus je voudrai que la fenêtre d'envoi s'ouvre une seule fois, même avec plusieurs destinataires, afin que mes collaborateurs ne fassent qu'une fois la manipulation.

Si quelqu'un a une idée...

bonne journée.

 

[Lone-wolf]

Bonjour Nickal

Option Explicit

Sub Envoi_Mail()
Dim StrBody As String, Chemin As String, Fichier As String, nom As String
Dim Sujet As String, feuille As String, depot As String, annee As String
Dim olApp As Object, derlig As Long, i As Integer, EnvoisA As String, olMail, Liste

    With Sheets(1)
        nom = .Range("A6").Value & ".xls"  'Nom de la feuille à envoyer
        feuille = .Range("A7").Value
        depot = .Range("A8").Value
        annee = .Range("A9").Value
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)

    Sujet = feuille & " " & depot & " : Compte-rendu " & annee
    StrBody = "Bonjour Medames, Messieurs," & vbCrLf & vbCrLf & "Votre nouveau classeur en pièce jointe"
    Chemin = ThisWorkbook.Path & "\"    ' à modifier si nécessaire
   
    Sheets(1).Copy
    ActiveSheet.SaveAs Filename:=Chemin & nom, FileFormat:=xlExcel8
    ActiveWorkbook.Close True
    Fichier = Chemin & nom
   
    With Sheets(2)  'Ici met toutes les adresses email
        EnvoisA = .Range("a2")  'Envoyer à
        derlig = .Range("a" & Rows.Count).End(xlUp).Row
        For i = 3 To derlig
            Liste = Liste & .Cells(i, 1).Value & ";"  'Copies cachées
        Next i
    End With

    With olMail
        .To = EnvoisA
        .BCC = Liste
        .Subject = Sujet
        .Body = StrBody
        .Attachments.Add Fichier
        .Display    'Pour afficher avant envois
        '.Send 'Pour envoyer
    End With

    Set olMail = Nothing
    Set olApp = Nothing
End Sub

 

[Nickal]

Bonjour Nickal

Option Explicit

Sub Envoi_Mail()
Dim StrBody As String, Chemin As String, Fichier As String, nom As String
Dim Sujet As String, feuille As String, depot As String, annee As String
Dim olApp As Object, derlig As Long, i As Integer, EnvoisA As String, olMail, Liste

    With Sheets(1)
        nom = .Range("A6").Value & ".xls"  'Nom de la feuille à envoyer
        feuille = .Range("A7").Value
        depot = .Range("A8").Value
        annee = .Range("A9").Value
    End With

    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)

    Sujet = feuille & " " & depot & " : Compte-rendu " & annee
    StrBody = "Bonjour Medames, Messieurs," & vbCrLf & vbCrLf & "Votre nouveau classeur en pièce jointe"
    Chemin = ThisWorkbook.Path & "\"    ' à modifier si nécessaire
  
    Sheets(1).Copy
    ActiveSheet.SaveAs Filename:=Chemin & nom, FileFormat:=xlExcel8
    ActiveWorkbook.Close True
    Fichier = Chemin & nom
  
    With Sheets(2)  'Ici met toutes les adresses email
        EnvoisA = .Range("a2")  'Envoyer à
        derlig = .Range("a" & Rows.Count).End(xlUp).Row
        For i = 3 To derlig
            Liste = Liste & .Cells(i, 1).Value & ";"  'Copies cachées
        Next i
    End With

    With olMail
        .To = EnvoisA
        .BCC = Liste
        .Subject = Sujet
        .Body = StrBody
        .Attachments.Add Fichier
        .Display    'Pour afficher avant envois
        '.Send 'Pour envoyer
    End With

    Set olMail = Nothing
    Set olApp = Nothing
End Sub

 

[Nickal]

Bonjour,

Merci pour le code, je l'ai adapté et cela fonctionne.

Dans le soucis de "quelques petites améliorations" j'ai mis en pièce jointe mon fichier définitif (avec le code VBA) que mes collaborateurs me renverront chaque jour.

J'ai 3 questions :

1 - Comment faire pour que le classeur me soit renvoyé dans le même format que celui d'origine (xlsm) car avant l'envoi cela me met un message de compatibilité et les mises en forme conditionnelles sautent...

2 - Pour la feuille 2, l'adresse en A2 est le destinataire principal, mais il faudrait que de A3 à Ai ce soit des destinataires en copies, et non en copies cachées...

3 - Là un peu plus difficile (j'ai essayé avec un ancien code qui permettait de le faire mais en vain), comment faire pour que quel que soit l'emplacement depuis lequel le tableur est ouvert, la copie pour l'envoi soit ensuite automatiquement supprimée ?

D'avance merci.

 

[Lone-wolf]

Bonsoir Nickal

Pour la 1ère question. le plus simple est de l'écrire dans le message.
Pour la 2ème, c'est de la colonne A à la colonne AI???
Pour la 3ème, je vais ajouter cela au code.

 

[Nickal]

Bonjour Lone-wolf,

Merci pour la prise en compte de mes petites questions...

Ci dessous un code que l'on m'avait proposé et qui permet de conserver le format (l'extension) du classeur Excel, et qui supprime le fichier envoyé après l'envoi (cela peut être une piste...).
Mais cette macro passe par une messagebox etc. ce qui est moins pratique par rapport à mon besoin. Je préfère ta solution de mettre directement le fichier avec un texte adapté dans un message. Mes collaborateurs ne seront pas perturbés.

Sub Envoi()
Dim tabDest()
Dim melSujet As String
Dim melAccuseReception As Boolean
Dim melFeuille As String
Dim nomActuel
Dim cptEnvoi
Dim repActuel

Dim savEnvoi As Boolean
Dim estEnvoi As Boolean
Dim repEnvoiOk As Boolean

tabDest = Range("listeEnvoi")

nomActuel = ActiveSheet.Name
repActuel = ActiveWorkbook.Path

melFeuille = Range("I1").Value

Sujet = melFeuille
AccuseReception = True

Application.ScreenUpdating = False

savEnvoi = False
estEnvoi = False

For cptEnvoi = 1 To UBound(tabDest, 1)
If Not (tabDest(cptEnvoi, 3) = "") Then
estEnvoi = True
repEnvoiOk = _
MsgBox( _
"Merci pour votre contribution." & _
"Votre message va être envoyé à " & tabDest(cptEnvoi, 2) & "." & _
vbCrLf & vbCrLf & _
"Vous recevrez bientôt un accusé de lecture dans votre messagerie. La feuille transmise n'est pas archivée sur votre ordianateur. elle sera accessible dans vos messages envoyés." & _
vbCrLf & vbCrLf & _
"VOULEZ-VOUS VRAIMENT TRANSMETTRE LA FEUILLE DE CALCUL ?", _
vbQuestion + vbYesNo, "TRANSMISSION DE LA FEUILLE") _
= vbYes

If Not savEnvoi And repEnvoiOk Then
' Exporter la feuille en la renommant
ActiveWorkbook.ActiveSheet.Copy
With ActiveWorkbook
.Sheets(1).Name = melFeuille
.ActiveSheet.Shapes.Range(Array("btnValider")).Delete
Cells(27, 1) = "Envoyé le " & Now & " par " & Application.UserName
End With
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs repActuel & "\" & melFeuille
Application.DisplayAlerts = True
' Une seule fois
savEnvoi = True
End If

If repEnvoiOk Then
' Procedure si Confiramation
ActiveWorkbook.SendMail tabDest(cptEnvoi, 3), Sujet, AccuseReception
Else
' Procedure si Non Confirmation
MsgBox "Votre envoi a été annulé !", vbInformation + vbOKOnly, "Pour information"
End If
End If
Next

If repEnvoiOk Then
ActiveWorkbook.Close False
If ExisteFichier(repActuel & "\" & melFeuille & ".xls*") Then
Kill repActuel & "\" & melFeuille & ".xls*"
End If
End If

If Not estEnvoi Then
If MsgBox( _
"Votre fichier n'a pas été envoyé !" & _
vbCrLf & vbCrLf & _
"Il y a un problème dans la configuration de votre liste d'envoi" & _
vbCrLf & vbCrLf & _
"Voulez-vous envoyer un avis à votre responsable ?" _
, vbCritical + vbYesNo, "Désolé !") _
= vbYes Then
EnvoyerAvis
End If
End If

Application.ScreenUpdating = True

End Sub

 

[Lone-wolf]

Re

2 - Pour la feuille 2, l'adresse en A2 est le destinataire principal, mais il faudrait que de A3 à Ai ce soit des destinataires en copies, et non en copies cachées...

ça c'est déjà fait, mais tu n'a pas répondu à ma question 2: c'est de la colonne A à la colonne AI???

Si non, voici ton fichier.

 

[Nickal]

Re



ça c'est déjà fait, mais tu n'a pas répondu à ma question 2: c'est de la colonne A à la colonne AI???

Si non, voici ton fichier.

 

[Nickal]

Pour la question 2 est possible de mettre un tableau comme dans le fichier joint de manière à bien visualiser les destinataires ?

Sinon je crois que ton fichier n'a pas été joint...

 

[Lone-wolf]

Re

Sinon je crois que ton fichier n'a pas été joint...

C'est l'heure de se réveiller mon ami! Et il ne faut pas croire, il faut être sûr, regarde bien mon dernier post.

Pour la feuille 2, il faudrait que de A3 à Ai ce soit des destinataires en copies, et non en copies cachées...

Tu pourrais m'expliquer maintenant pourquoi ce tableau???

 

[Nickal]

Effectivement ... mea culpa.
Ben je crois que ce que tu m'as envoyé répond parfaitement à ce que je souhaitais (même plus) !
Pour le tableau c'était histoire d'avoir de la clarté mais là tout fonctionne et comme la feuille des destinataires est masquée alors pas de soucis.

Puis-je me permettre un petit complément ?
Au moment de la validation, peut-on avoir un message stoppant l'envoi si la date n'est pas renseignée dans B6 ? (genre "Veuillez renseigner la date.").

 

[Lone-wolf]

Re

Voilà qui est fait.

 

[Nickal]

C'est absolument parfait !
Merci pour tout, il y a quelque chose à valider ?

 

[Lone-wolf]

Re

il y a quelque chose à valider ?

De quoi tu parle???

 

[Nickal]

D'une validation de la solution pour clore le sujet ?