XL 2016 VBA- Créer copie d'une plage de cellule dans nouveau classeur et envoyer par mail

[MONTREAL2020]

Bonjour,

Peu de connaissances en VBA, je voulais faire ce qui suit:
Dans une feuille précise d'un classeur ouvert
- Créer un nouveau classeur
- Copier une plage de cellules depuis le classeur initial vers le nouveau classeur en gardant la mise en forme mais sans les formules
- Lui donner un nom et le sauvegarder dans un dossier (X)
- Faire appel au nouveau classeur
- Envoyer le classeur par email
- Fermer le classeur crée

Voila

J'ai trouvé un Code en cherchant sur le net, mais ca ne marche pas , ca bloque sur (.Send)

Merci par avance pour votre support

En PJ un exemple de fichier

 

[AtTheOne]

Bonsoir à toutes & à tous, bonsoir @MONTREAL2020
Bon ton sujet n'inspire pas les foules. Il faut dire que l'envoi de mails grâce à CDO n'est pas inné.
Dans l'exemple que je te fournis j'ai mis deux services d'expédition au choix Outlook ou CDO.
Pour CDO, cela ne fonctionne pas dans tous les cas. J'ai testé free.fr et laposte.net qui sont OK mais aussi gmail.com qui ne fonctionne pas ... sans doute un problème de sécurité.

Sur ton exemple j'ai nommé les plages de cellules qui servent à la macro

Noms	Adresse	Utilisation
Plage_Mail	=RÉCAP!$B$2:$P$12	la plage de cellules à envoyer en PJ
Destinataires	=t_destinataires	un tableau pour choisir des destinataires
Destinataire	=RÉCAP!$C$15	le destinataire choisi
Service	=RÉCAP!$N$20	le choix entre Outlook et CDO
Expéditeur	=RÉCAP!$S$8	l'adresse mail de l'expéditeur (pour CDO)
MotDePasse	=RÉCAP!$S$10	le mot de passe de l'expéditeur (pour CDO)
ServeurSMTP	=RÉCAP!$S$12	le serveur SMTP de l'herbergeur (pour CDO)

La macro principale:

Sub EnvoiMessage()
     Dim Source As Range, Wbk As Workbook, Cible As Range, FS As Object
     Dim Service$, Objet$, Corps$, Signature$, Destinataire$, Expéditeur$, ServeurSMTP$, Motdepasse$, NomFich$
    
     'Création de la pièce jointe
     Application.ScreenUpdating = False
     Set Source = ThisWorkbook.Worksheets("RÉCAP").[Plage_Mail]
     Set Wbk = Workbooks.Add
     Set Cible = Wbk.Worksheets(1).[A1].Resize(Source.Rows.Count, Source.Columns.Count)
     Source.Copy Destination:=Cible
     Cible.Value = Cible.Value            'Transformer les formules en valeurs
    
     'Enregistrement dans le répertoire temporaire
     Set FS = CreateObject("Scripting.FileSystemObject")
     Nom = FS.GetbaseName(ThisWorkbook.FullName)    
     TempFileName = "Recap Jour «" & Nom & "» " & Format(Now, "dd-mmm-yy")
     TempPath = Environ$("temp") & "\"
     Wbk.SaveAs TempPath & TempFileName, FileFormat:=xlOpenXMLWorkbook
     NomFich = Wbk.FullName
     Wbk.Close
    
     Application.ScreenUpdating = True

     'Données du message
     With ThisWorkbook.Worksheets("RÉCAP")
          Service = .[Service]
          Expéditeur = .[Expéditeur]
          Destinataire = .[Destinataire]
          ServeurSMTP = .[ServeurSMTP]
          Motdepasse = .[Motdepasse]
     End With
    
     'A adapter   
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
     Objet = "Récapitulatif du " & Format(Now, "dd/mm/yyyy")
     Signature = "Mr xxxxxxxxxx" & vbCrLf & "Responsable xxxxxxxxx"
     Corps = "Bonjour," & vbCrLf & "je vous pris de bien vouloir recevoir le mail de la recap du jour," & vbCrLf & "cordialement" & vbCrLf & Signature
    '¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯ 
     'Envoi du mail choix Outlook, CDO
     Select Case Service
     Case "Outlook"
          OLK_Mail Destinataire, Objet, Corps, NomFich
     Case "CDO"
          CDO_Mail Expéditeur, ServeurSMTP, Motdepasse, Destinataire, Objet, Corps, NomFich
    End Select
    
     Kill NomFich
    
End Sub

La macro d'envoi via Outlook

Sub OLK_Mail(Destinataire$, Objet$, Corps$, NomFich$)
     'Envoi du mail par Outlook
     Dim OlkApp As Object, OlkMail As Object
     Set OlkApp = CreateObject("Outlook.Application")
     Set OlkMail = OlkApp.CreateItem(0)
    
     On Error Resume Next
     With OlkMail
          .To = Destinataire
          .CC = ""
          .BCC = ""
          .Subject = Objet
          .Body = Corps
          .Attachments.Add NomFich
          .Send
     End With
     On Error GoTo 0
    
     OlkApp.Quit
     Set OlkMail = Nothing
     Set OlkApp = Nothing
End Sub

La macro d'envoi via CDO

Sub CDO_Mail(Expéditeur$, ServeurSMTP$, Motdepasse$, Destinataire$, Objet$, Corps$, NomFich$)
     'Envoi du mail par CDO
     Dim iMsg As Object, iConf As Object, Flds As Variant
    
     Set iMsg = CreateObject("CDO.Message")
     Set iConf = CreateObject("CDO.Configuration")
    
     iConf.Load -1     'Config par défaut
     Set Flds = iConf.Fields
     With Flds
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
          .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Expéditeur
          .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Motdepasse
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = ServeurSMTP
          
          .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
          .Update
     End With

     With iMsg
          Set .Configuration = iConf
          .To = Destinataire
          .CC = ""
          .BCC = ""
          .From = """" & Application.UserName & """ <" & Expéditeur & ">"
          .Subject = "Récapitulatif du " & Format(Now, "dd/mm/yyyy")
          .TextBody = Corps
          .AddAttachment NomFich
          .Send
     End With
    
     Set iMsg = Nothing
     Set iConf = Nothing
     Set Flds = Nothing
End Sub

Une copie d'écran :

Vois le fichier joint
Amicalement
Alain

 

[MONTREAL2020]

Bonjour AtTheOne,

C'est vrai le sujet semble faire fuir les codeurs.

Je vous remercie vivement pour votre réponse, je vais la tester à voir qu'est ce que cela donnera.

Bonne journée

 

[MONTREAL2020]

Re-bonjour,

Je reviens vers vous Alain, le code marche super bien sur Outlook. Toutefois, il le fichier bogue dès le 1er envoi.

J'ai tenté de fermer et le réouvrir afin de m'en assurer que c'est juste un gel, mais néanmoins cela persiste.

Merci infiniment

 

[AtTheOne]

Bonjour à toutes & à tous, bonjour @MONTREAL2020

Toutefois, il le fichier bogue dès le 1er envoi.

Peux-tu préciser un peu plus (quel bogue ?) car chez moi j'enchaîne les envois sans problème ...
Amicalement
Alain

 

[MONTREAL2020]

Bonjour à toutes & à tous, bonjour @MONTREAL2020

Peux-tu préciser un peu plus (quel bogue ?) car chez moi j'enchaîne les envois sans problème ...
Amicalement
Alain

au fait c'est le classeur qui bloque, aucune manipulation n'est possible.

 

[AtTheOne]

Bonne nuit !
Peux-tu renvoyer le classeur qui bloque en PJ ?
Qu'on voit si c'est le classeur ou un problème de config.
Amicalement
Alain

 

[MONTREAL2020]

Bonjour Alain,
Merci pour ton assistance, j'apprécie énormément.
Tu trouveras en PJ le fichier, mais aussi à ma surprise ce matin quand je roule al macro, ma session outlook se ferme !!!.

Je te souhaite une excellente journée

 

[AtTheOne]

Bonjour @MONTREAL2020

ma session outlook se ferme !!!.

Bon ça c'est facile, ça vient de l'instruction "OlkApp.Quit" que j'ai mise dans la Sub OLK_Mail(Destinataire$, Objet$, Corps$, NomFich$) :

    .....
     On Error GoTo 0
  
     OlkApp.Quit   'A supprimer ou mettre en commentaire
     Set OlkMail = Nothing
     Set OlkApp = Nothing
End Sub
/CODE]

tu peux la supprimer

Pour le reste, la version que j'ai reçue fonctionne chez moi (avec l'adresse que j'utilise et Outlook, avec deux adresses et CDO) difficile de t'aider dans ce cas.
Mais on peut essayer pas à pas d'abord d'exécuter un Msgbox au lieu d'envoyer un mail pour discerner la partie du code qui pose problème. je te propose de mettre en commentaire une partie du code et de la remplacer par des msgbox :

     ....
     'Envoi du mail choix Outlook, CDO
     Select Case Service
     Case "Outlook"
'         OLK_Mail Destinataire, Objet, Corps, NomFich
         Msgbox "Vous avez choisi Outlook ..."
     Case "CDO"
'         CDO_Mail Expéditeur, ServeurSMTP, Motdepasse, Destinataire, Objet, Corps, NomFich
         Msgbox "Vous avez choisi CDO..."
     End Select
     ....

Si tu peux simuler tes envois sans problème, c'est que le problème viens d'un des sub OLK_Mail ou CDO_Mail ...

Bon courage
Amicalement
Alain

 

[MONTREAL2020]

Bonjour @MONTREAL2020

Bon ça c'est facile, ça vient de l'instruction "OlkApp.Quit" que j'ai mise dans la Sub OLK_Mail(Destinataire$, Objet$, Corps$, NomFich$) :

    .....
     On Error GoTo 0
 
     OlkApp.Quit   'A supprimer ou mettre en commentaire
     Set OlkMail = Nothing
     Set OlkApp = Nothing
End Sub
/CODE]

tu peux la supprimer

Pour le reste, la version que j'ai reçue fonctionne chez moi (avec l'adresse que j'utilise et Outlook, avec deux adresses et CDO) difficile de t'aider dans ce cas.
Mais on peut essayer pas à pas d'abord d'exécuter un Msgbox au lieu d'envoyer un mail pour discerner la partie du code qui pose problème. je te propose de mettre en commentaire une partie du code et de la remplacer par des msgbox :

     ....
     'Envoi du mail choix Outlook, CDO
     Select Case Service
     Case "Outlook"
'         OLK_Mail Destinataire, Objet, Corps, NomFich
         Msgbox "Vous avez choisi Outlook ..."
     Case "CDO"
'         CDO_Mail Expéditeur, ServeurSMTP, Motdepasse, Destinataire, Objet, Corps, NomFich
         Msgbox "Vous avez choisi CDO..."
     End Select
     ....

Si tu peux simuler tes envois sans problème, c'est que le problème viens d'un des sub OLK_Mail ou CDO_Mail ...

Bon courage
Amicalement
Alain

Bonjour @MONTREAL2020

Bon ça c'est facile, ça vient de l'instruction "OlkApp.Quit" que j'ai mise dans la Sub OLK_Mail(Destinataire$, Objet$, Corps$, NomFich$) :

    .....
     On Error GoTo 0
 
     OlkApp.Quit   'A supprimer ou mettre en commentaire
     Set OlkMail = Nothing
     Set OlkApp = Nothing
End Sub
/CODE]

tu peux la supprimer

Pour le reste, la version que j'ai reçue fonctionne chez moi (avec l'adresse que j'utilise et Outlook, avec deux adresses et CDO) difficile de t'aider dans ce cas.
Mais on peut essayer pas à pas d'abord d'exécuter un Msgbox au lieu d'envoyer un mail pour discerner la partie du code qui pose problème. je te propose de mettre en commentaire une partie du code et de la remplacer par des msgbox :

     ....
     'Envoi du mail choix Outlook, CDO
     Select Case Service
     Case "Outlook"
'         OLK_Mail Destinataire, Objet, Corps, NomFich
         Msgbox "Vous avez choisi Outlook ..."
     Case "CDO"
'         CDO_Mail Expéditeur, ServeurSMTP, Motdepasse, Destinataire, Objet, Corps, NomFich
         Msgbox "Vous avez choisi CDO..."
     End Select
     ....

Si tu peux simuler tes envois sans problème, c'est que le problème viens d'un des sub OLK_Mail ou CDO_Mail ...

Bon courage
Amicalement
Alain

Bonjour Alain,

Désolé d'avoir pris du temps pour te répondre.
Ca marche comme sur des roulettes

Merci encore une fois pour ton aide et ta disponibilité.