envoi d'une selection de cellules par mail Fermé

Question

Bonjour, 

J'ai sous Excel 2010 une feuille de calcul avec des colonnes de « A » à « BC » et des lignes de « 1 » à « 100 », je voudrais envoyer par mail uniquement la sélection suivante : $A$3 :$AA$55.
 si j'utilise l'option définir zone d'impression et que j'envoie le fichier par mail, le destinataire reçoit la totalité de la feuille au lieu de la sélection.
Je suis novice en VBA quelqu'un aurait-il un code pour faire cela à partir d'un bouton ?
Merci d'avance


Configuration: Windows 7 / Internet Explorer 9.0

Mike-31 · Answer

Salut,   

 ce n'est pas un problème, tu peux envoyer la plage que tu souhaites sans passer par ta messagerie, directement en CDO.   
Mais avec un code VBA il faut être précis. Tu veux envoyer la plage $A$3 :$AA$55 mais de quel onglet, l'onglet actif ou lequel et comment se nomme t il   

et en extension XLS, XLSX ou en PDF ce qui offre plus de sécurité et limite les problèmes liés à la possession d' Excel et de ses versions
    
A+   
Mike-31   

Une période d'échec est un moment rêvé pour semer les graines du savoir.

maya · Answer

Bonjour Mike_31
merci pour ta réponce
mon onglet s'appelle "FORMULAIRE"
en fait ce classeur comporte un modele pour les personnes qui doivent le remplir, et ne me renvoi par mail que la partie remplie.

Mike-31 · Answer

Re,

Je ne t'oublie pas, je te fais un exemple envoi PDF et XLS dans la soirée

Mike-31 · Answer

Re,

teste ce fichier

https://www.cjoint.com/?BJsxn5JSAcU

Mike-31 · Answer

Re,

Je l'ai écrit sur Excel 2007 et il fonctionne parfaitement.
Suite à la remarque de Eriiic que je salue je revois le code pour tester les versions Excel.
Je posterais un fichier en début d'après midi que tu pourras tester sur Excel 2010 et Eriiic sur 2003

Mike-31 · Answer

Re,

En début de code renseigner les constantes adresse destinataire, SMPT et éventuellement Adresse expéditeur

Const Dest As Variant = "wwwwwwwwwww@free.fr" 
Const C_Ent As Variant = "SMTP.free.fr"

Const Exped As Variant = "www.xxxxxxx@free.fr" 

https://www.cjoint.com/?BJtl3GkxOPr

maya · Answer

RE.
Bon, les gars et bien le problème s'est moi....

Message en exécution

« Microsoft Excel
   Le message n'a pas pu etre envoyé vers les serveur SMTP. Le code d'erreur de transport        était 0x80040217. La réponse de serveur était not available. »

sans abuser, y a t'il une possibilité d'ouvrir directement Outloock

@+ maya

Mike-31 · Answer

Re, 

Je te signale que le code à évolué grâce au échanges avec Eriiic et par la même résous tes problèmes. 
Pour ma part il y a longtemps que j'ai abandonné Outlook

As-tu bien renseigné les constantes en début de code (adresse mail, smtp) 

Quel est ton fournisseur d'accès internet 

  
A+ 
Mike-31 

Une période d'échec est un moment rêvé pour semer les graines du savoir.

maya · Answer

oui j'ai bien renseigner les adresses mail et le smtp, mon fournisseur d'accès et Orange
merci quand même
@+

Mike-31 · Answer

Re, 

Cette constante tu l'as bien saisie comme cela avec les guillemets 

 Const C_Ent As Variant = "SMTP.orange.fr"  
  
A+ 
Mike-31 

Une période d'échec est un moment rêvé pour semer les graines du savoir.

maya · Answer

oui
@+

Mike-31 · Answer

Re,

Tu utilises bien mon fichier exemple sur lequel tu as saisi l'adresse mail et le smtp 
 
Const Dest As Variant = "wwwwwwwwwww@free.fr"
Const C_Ent As Variant = "SMTP.orange.fr"

maya · Answer

re
oui, je l'ai enregistré sur mon disque dur, j'ai bien remplacé se que dit m'a en respectant la casse
maintemant dans outlook j'ai des informations utilisateur: avec un utilsateur avec un mot de passe pour la connexion au serveur d'orange (Oleane VPN)
@+

Mike-31 · Answer

Re, 

Bizarre parce que ce procédé n'utilise aucune messagerie, on sort directement avec le fournisseur d'accès. 
par contre si tu veux utiliser Outlook j'ai des codes que je ne peux pas tester

redémarre ton ordi pour voir.  
  
A+ 
Mike-31 

Une période d'échec est un moment rêvé pour semer les graines du savoir.

eriiic · Answer

Re,    

Je viens de retester plus complètement (sur orange) et c'est ok.    

 A noter qu'il faut compléter/modifier ces lignes :    
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25    
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ""    
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ""    
Mike, tu pourrais les remonter (et les 3 autres) en constantes en haut du code.    
Il faut peut-être garder séparés Exped et sendusername ? (en cas d'utilisation du smtp d'un autre opérateur)    

Param pour Oléane :    
smtp par: smtp.msa.orange-business.com    
port smtp : 587     
     
Sinon il reste la possibilité d'utiliser le smtp d'un autre opérateur, en mettant sa vraie adresse email pour la réponse.    
J'ai voulu tester avec gmail (SMTP.gmail.com, port 587) mais je me fais jeter :    
"...Must issue STARTTLS command first..."    
Mike, si tu as rencontré comment activer ce TLS au cours de tes pérégrinations (?)    

eric    

PS: au passage j'ai trouvé ça qui pourra servir :    
The reply email address : .item(http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress) = ""  

Jamais tu ne répondras à un mp non sollicité...    
Bon, ça c'est fait.

maya · Answer

re
en entrant les parametres du compte en dur çà fonctionne
Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxxx@xxxxxxxxxxx" 
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "yyyyyyy" 

merci à vous deux, passez un bon week-end.

Mike-31 · Answer

Re,  

ces deux lignes gèrent les authentifications de connexion   
cette ligne   
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Nom utilisateur messagerie"  
cette ligne   
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "mot de passe"  

cela rejoint ma question sur les connexions sécurisées notamment en Suisse ou sur certains serveurs  
 Dans le cas contraire, ces deux lignes peuvent être supprimées  

Pour répondre à Eriiic oui on peut tout remonter en constante cela facilite les modifications, c'est pour cela que je disais d'attendre afin que je trouve le temps de compléter le code.  

la ligne que tu proposes 
 .item(http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress) = "" 
en fait je l'ai oubliée, je l'ai traitée en constante et pas placée dans la série des Items 
Const Exped As Variant = "www.xxxxxxx@free.fr" '----- adresse mail de l'expéditeur 
Erreur de ma part, il aurait été dommage qu'elle soit absente du code Merci pour cette remarque 


J'ai à plusieurs reprises proposé ce code  sur ce forum qu'il est possible de retrouver mais je passe le statut de cette discussion en résolu de sorte qu'elle serve de référence, dans les prochains jours j'en ferai une astuce
A+  
Mike-31  

Une période d'échec est un moment rêvé pour semer les graines du savoir.

Mike-31 · Answer

Re,

voila le code complet annoté

Option Explicit

Sub Envoi_Mail ()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb, Destwb As Workbook
Dim TempFilePath, TempFileName As String
Dim Wb, iMsg, iConf As Object
Dim Flds As Variant
'--------------------------- Constante à renseigner
Const Feuille As Variant = "FORMULAIRE" '------------- nom de la feuille à copier
Const Plage As Variant = "A1:H10" '------------------- plage à copier
Const Dest As Variant = "michel.wwwwwwwwww@free.fr" '- adresse mail du destinataire
Const Exped As Variant = "www.xxxxxxx@free.fr" '------ adresse mail de réponse de l'expéditeur
Const C_Ent As Variant = "SMTP.free.fr" '------------- adresse du SMTP"
Const CC As Variant = "" '---------------------------- adresse mail CC
Const BCC As Variant = "" '--------------------------- adresse mail destinataire pour envoi BCC ou BCI ou CCI
Const NumPort As Variant = 25 '----------------------- n° port du serveur sortant
'--------------------------- Si la connexion nécessite une authentification
Const N_Messag As Variant = "Nom utilisateur messagerie"
Const Pass As Variant = "motdepasse"

On Error GoTo errorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Set Destwb = Workbooks.Add
Sourcewb.Sheets(Feuille).Range(Plage).Copy Destwb.ActiveSheet.Range("A1")
'--------------------------- Déterminer la version d'Excel et d'extension du fichier utilisé
With Destwb
If Val(Application.Version) < 12 Then
'--------------------------- Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'--------------------------- Excel 2007-2010
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Votre réponse est NON dans la boîte de dialogue de sécurité"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
'-------------------------- Nom du classeur expédié avec jour et heure d'envoi
TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 '--------- CDO Source Default
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = C_Ent '"smtp.free.fr" '"Saisir le SMTP du serveur sortant"
.Item("http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress") = Exped '"adresse email de réponse expéditeur"

.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = NumPort '25 'n° port du serveur sortant

'--------------------------- Si la connexion nécessite une authentification libérer les 3 lignes
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
'ou
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = N_Messag 'ou "Nom utilisateur messagerie"
' .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass 'ou "motdepasse"
.Update
End With
With iMsg
Set .Configuration = iConf
.To = Dest
.CC = CC
.BCC = BCC
.From = Exped
.Subject = [C1].Value
.TextBody = "Bonjour" & " " & [C2].Value & "," & vbCrLf & vbCrLf _
& "Veuillez trouvez ci-joint le " & [C3].Value & "." & vbCrLf & vbCrLf _
& [C4].Value & vbCrLf _
& [C5].Value & vbCrLf _
& [C6].Value & vbCrLf _
& [C7].Value & vbCrLf _
& [C8].Value & vbCrLf _
& [C9].Value & vbCrLf _
& [C10].Value & vbCrLf & vbCrLf _
& [C11]
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Le mail a été bien envoyé !" '---------- Confirmation de l'envoi
Exit Sub
'--------------------------- Si erreur on sort de la procédure
errorHandler:
'--------------------------- Description de l'erreur survenue
MsgBox Err.Description
'--------------------------- Si erreur ferme la copie temporaire
For Each Wb In Workbooks
If Left(Wb.Name, 1) <> "Claseur" And Wb.Name <> ThisWorkbook.Name Then
Wb.Close
End If
Next Wb
End Sub

A+
Mike-31

Une période d'échec est un moment rêvé pour semer les graines du savoir.

Mike-31 · Answer

Re, 

J'ai rajouté de de réponse  

j'ai également pensé, si la plage à copier contient des liaisons avec des cellules hors plage copiée ou autre feuille 

il faudra remplacer cette ligne  
Sourcewb.Sheets(Feuille).Range(Plage).Copy Destwb.ActiveSheet.Range("A1") 
qui peut s'écrire  
Sourcewb.Sheets(Feuille).Range(Plage).Copy Destwb.ActiveSheet.[A1] 

par, pour coller uniquement les valeurs 
    Sourcewb.Sheets(Feuille).Range(Plage).Copy 
    Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteValues 

éventuellement rajouter cette ligne si l'on veut coller les formats  
 Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteFormats 

et rajouter cette ligne pour désactiver le masque du collage, plus agréable à la réception 
    Destwb.ActiveSheet.[A1].Select  
A+ 
Mike-31 

Une période d'échec est un moment rêvé pour semer les graines du savoir.

maya · Answer

Salut les gars , j'espère que vous avez passé un bon week_end;

après toutes les modifications celà fonctionne, à un détail prés c'est que la copie ne garde pas la mise en page, y a t'il une possibilité de corriger celà

@+ et encore merci
maya

Mike-31 · Answer

Re,

que veux tu dire par mise en page, la largeur des colonnes
la hauteur de ligne
la colorisation de certaines cellules ou de police

maya · Answer

re
je veux dire par là: il garde tout sauf les largeurs de colonnes
@+ merci

Mike-31 · Answer

Re, colle ce code à la place de l'autre, n'oublie pas de renseigner les contantes Const Dest As Variant Const Exped As Variant Const C_Ent As Variant et celle ci si la plage à copier à changer Const Plage As Variant Sub Envoi_Mail () Dim cdoBasic Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb, Destwb As Workbook Dim TempFilePath, TempFileName As String Dim Wb, iMsg, iConf As Object Dim Flds As Variant '--------------------------- Constante à renseigner Const Feuille As Variant = "FORMULAIRE" '------------- nom de la feuille à cpier Const Plage As Variant = "A1:H10" '------------------- plage à copier, (Cells.Copy toute la feuille) Const Dest As Variant = "wwwwwwwwwww@free.fr" '- adresse mail du destinataire Const Exped As Variant = "www.xxxxxxx@free.fr" '------ adresse mail de réponse de l'expéditeur Const C_Ent As Variant = "SMTP.free.fr" '------------- adresse du SMTP (courrier entrant) Const CC As Variant = "" '---------------------------- adresse mail CC Const BCC As Variant = "" '--------------------------- adresse mail destinataire pour envoi BCC ou BCI ou CCI Const NumPort As Variant = 25 '----------------------- n° port du serveur sortant Const Nom_envoi As Variant = "Sourcewb.Name" '----------- nom identique du fichier expédié ou remplacer par "Nom souhaité" '--------------------------- Si la connexion nécessite une authentification Const N_Messag As Variant = "False" '----------------- Nom utilisateur messagerie, sinon mettre en "False" Const Pass As Variant = "False" '--------------------- motdepasse sinon mettre en Fase '--------------------------- Connexion en SSL comme gmail et hotmail etc... mettre la constante en "True" sinon "False" Const Typ_Conex As Variant = "False" '--------------------------- Début de procédure On Error GoTo errorHandler With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ActiveWorkbook Set Destwb = Workbooks.Add '-- Si la plage à copier contient des liaisons isoler la première ligne et libérer les lignes au dessous Sourcewb.Sheets(Feuille).Range(Plage).Copy Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteFormats '---- copie les format Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteValues '----- copie les valeurs Destwb.ActiveSheet.[A1].Select '--------------------------- Déterminer la version d'Excel et d'extension du fichier utilisé With Destwb If Val(Application.Version) < 12 Then '--------------------------- Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else '--------------------------- Excel 2007-2010 If Sourcewb.Name = .Name Then With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox "Votre réponse est NON dans la boîte de dialogue de sécurité" Exit Sub Else Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End If End With TempFilePath = Environ$("temp") & "\" '-------------------------- Nom du classeur expédié avec jour et heure d'envoi TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum .Close savechanges:=False End With Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") iConf.Load -1 ' CDO Source Defaults Set Flds = iConf.Fields With Flds .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = C_Ent '-------------- Saisir le SMTP du serveur sortant ex."smtp.free.fr" .Item("http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress") = Exped 'adresse email de réponse expéditeur .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = NumPort '-------- n° port du serveur sortant .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Typ_Conex '---------- Connexion particulière '--------------------------- Si la connexion nécessite une authentification libérer les 3 lignes .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic 'ou ' .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = N_Messag ' Nom utilisateur messagerie sinon False .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass ' motdepasse sinon False .Update End With With iMsg Set .Configuration = iConf .To = Dest .CC = CC .BCC = BCC .From = Exped .Subject = [C1].Value .TextBody = "Bonjour" & " " & [C2].Value & "," & vbCrLf & vbCrLf _ & "Veuillez trouvez ci-joint le " & [C3].Value & "." & vbCrLf & vbCrLf _ & [C4].Value & vbCrLf _ & [C5].Value & vbCrLf _ & [C6].Value & vbCrLf _ & [C7].Value & vbCrLf _ & [C8].Value & vbCrLf _ & [C9].Value & vbCrLf _ & [C10].Value & vbCrLf & vbCrLf _ & [C11] .AddAttachment TempFilePath & TempFileName & FileExtStr .Send End With With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox "Le mail a été bien envoyé !" '------------- Facultatif, confirmation de l'envoi Exit Sub '--------------------------- Si erreur on sort de la procédure errorHandler: '--------------------------- Description de l'erreur survenue MsgBox Err.Description '--------------------------- Si erreur ferme la copie temporaire For Each Wb In Workbooks If Left(Wb.Name, 1) <> "Claseur" And Wb.Name <> ThisWorkbook.Name Then Wb.Close End If Next Wb End Sub

maya · Answer

Re
J'ai fait un essai, j'ai un message qui me dit impossible de coller des cellules fusionnées de différentes tailles.
Au départ j'ai des colonnes de a à AA de largeur de colonne de 3 à 4, quand je reçois le fichier coller par mail, et que je l'ouvre j'ai des colonnes de largeur de 10.38
J'ai mis le fichier  exemple en ligne, se sera peut-être plus simple et mieux que mes explications :
http://cjoint.com/12oc/BJwrFPNiCOb.htm
@+

maya · Answer

re
petite precision le fichier définitif sera protegé, celà peut il avoir une incidence?

Mike-31 · Answer

Colle simplement ce code à la place de l'autre, renseigne les constantes Const Dest As Variant = "wwwwwwwwww@free.fr" Const Exped As Variant = "www.xxxxxxx@free.fr" Const C_Ent As Variant = "SMTP.free.fr" Si ça bloque il faudra regarder dans ta messagerie le N° du port sortant mais je te dirais plus tard, normalement c'est bien le 25 Option Explicit Sub Envoi_Mail() Dim cdoBasic Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb, Destwb As Workbook Dim TempFilePath, TempFileName As String Dim Wb, iMsg, iConf As Object Dim Flds As Variant '--------------------------- Constante à renseigner Const Feuille As Variant = "FORMULAIRE" '------------- nom de la feuille à cpier Const Plage As Variant = "Cells" '------------------- plage à copier, (Cells.Copie toute la feuille) Const Dest As Variant = "wwwwwwwwww@free.fr" '- adresse mail du destinataire Const Exped As Variant = "www.xxxxxxx@free.fr" '------ adresse mail de réponse de l'expéditeur Const C_Ent As Variant = "SMTP.free.fr" '------------- adresse du SMTP (courrier entrant) Const CC As Variant = "" '---------------------------- adresse mail CC Const BCC As Variant = "" '--------------------------- adresse mail destinataire pour envoi BCC ou BCI ou CCI Const NumPort As Variant = 25 '----------------------- n° port du serveur sortant Const Nom_envoi As Variant = "Sourcewb.Name" '----------- nom identique du fichier expédié ou remplacer par "Nom souhaité" '--------------------------- Si la connexion nécessite une authentification Const N_Messag As Variant = "False" '----------------- Nom utilisateur messagerie, sinon mettre en "False" Const Pass As Variant = "False" '--------------------- motdepasse sinon mettre en Fase '--------------------------- Connexion en SSL comme gmail et hotmail etc... mettre la constante en "True" sinon "False" Const Typ_Conex As Variant = "False" '--------------------------- Début de procédure On Error GoTo errorHandler With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ActiveWorkbook Set Destwb = Workbooks.Add '-- Si la plage à copier contient des liaisons isoler la première ligne et libérer les lignes au dessous Sourcewb.Sheets(Feuille).Cells.Copy Destwb.ActiveSheet.[A1] ' Sourcewb.Sheets(Feuille).Range(Plage).Copy Destwb.ActiveSheet.[A1] ' Sourcewb.Sheets(Feuille).Range(Plage).Copy ' Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteFormats '---- copie les format ' Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteValues '----- copie les valeurs ' Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths '---- copie les formats colonnes ' Destwb.ActiveSheet.[A1].Select '--------------------------- Déterminer la version d'Excel et d'extension du fichier utilisé With Destwb If Val(Application.Version) < 12 Then '--------------------------- Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else '--------------------------- Excel 2007-2010 If Sourcewb.Name = .Name Then With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox "Votre réponse est NON dans la boîte de dialogue de sécurité" Exit Sub Else Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End If End With TempFilePath = Environ$("temp") & "\" '-------------------------- Nom du classeur expédié avec jour et heure d'envoi TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum .Close savechanges:=False End With Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") iConf.Load -1 ' CDO Source Defaults Set Flds = iConf.Fields With Flds .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = C_Ent '-------------- Saisir le SMTP du serveur sortant ex."smtp.free.fr" .Item("http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress") = Exped 'adresse email de réponse expéditeur .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = NumPort '-------- n° port du serveur sortant .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Typ_Conex '---------- Connexion particulière '--------------------------- Si la connexion nécessite une authentification libérer les 3 lignes .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic 'ou ' .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = N_Messag ' Nom utilisateur messagerie sinon False .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass ' motdepasse sinon False .Update End With With iMsg Set .Configuration = iConf .To = Dest .CC = CC .BCC = BCC .From = Exped .Subject = [C1].Value .TextBody = "Bonjour" & " " & [C2].Value & "," & vbCrLf & vbCrLf _ & "Veuillez trouvez ci-joint le " & [C3].Value & "." & vbCrLf & vbCrLf _ & [C4].Value & vbCrLf _ & [C5].Value & vbCrLf _ & [C6].Value & vbCrLf _ & [C7].Value & vbCrLf _ & [C8].Value & vbCrLf _ & [C9].Value & vbCrLf _ & [C10].Value & vbCrLf & vbCrLf _ & [C11] .AddAttachment TempFilePath & TempFileName & FileExtStr .Send End With With Application .ScreenUpdating = True .EnableEvents = True End With MsgBox "Le mail a été bien envoyé !" '------------- Facultatif, confirmation de l'envoi Exit Sub '--------------------------- Si erreur on sort de la procédure errorHandler: '--------------------------- Description de l'erreur survenue MsgBox Err.Description '--------------------------- Si erreur ferme la copie temporaire For Each Wb In Workbooks If Left(Wb.Name, 1) <> "Claseur" And Wb.Name <> ThisWorkbook.Name Then Wb.Close End If Next Wb End Sub

fabidou49 · Answer

Tout d'abord merci aux personnes qui ont expliqués, fournie cette macro.

Chez moi elle fonctionne tres bien, mais je voudrais au lieu d'envoyer le classeur au format .xls, l'envoyer en format PDF. J'ai essayé de remplacer le .xls par .pdf, mais la personne qui reçois le document ne peut l'ouvrir. Je voudrais donc savoir comment procéder.

De plus, je voudrais aussi enregistrer la feuille envoyée (toujours en pdf), dans dossier "c: ....." pour garder une trace de mon envoi. 

Dernière demande, et désolé d'être aussi exigent, la feuille que je fais est une quittance de loyer. J'arrive a mettre la date d'envoi en automatique, par contre je voudrais pouvoir ecrire ceci, dans une ou plusieurs cellule de façon automatique comme la date, exemple: période du xxx au xxx. les "xxx" seront remplacés par la période que couvre la quittance, soit du 01 mars 2013 au 31 mars 2013. Il faut donc gérer si le mois est a 30 jour ou 31 ou 28 pour février.

Je vous remercie par avance pour vos lumières.

Envoi d'une selection de cellules par mail

27 réponses

Discussions similaires