Envoyer une feuille de mon classeur par mail en pièce jointe
Bonjour,
J'aimerai avoir un coup de main pour mon problème. J'ai plusieurs feuilles dans mon classeur et j'aimerai mettre en pièce jointe une de ces feuilles. J'ai un code VBA qui m'envoie le classeur entier et je n'arrive pas à le modifier pour envoyer q'une seul feuille.
Voici le code en question:
Sub CDO_Mail_Small_Text_2()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Dim Fichier As String
Dim SourceWb As Workbook
Set SourceWb = ActiveWorkbook
Fichier = ThisWorkbook.Path & Application.PathSeparator & "j1.xls"
SourceWb.SaveCopyAs Fichier
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/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxxxxxxxxxx@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxx"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Update
End With
strbody = "Bonjour, Voici la prochaine journée a compléter avant Vendredi 18h. Merci!"
With iMsg
Set .Configuration = iConf
.To = "xxxxxxxxxxxx@gmail.com"
.CC = ""
.BCC = ""
' Note: The reply address is not working if you use this Gmail example
' It will use your Gmail address automatic. But you can add this line
' to change the reply address .ReplyTo = "Reply@something.nl"
.From = """Pronos"" <xxxxxxxxxxxxxxxx@gmail.com>"
.Subject = "Journée 1"
.TextBody = strbody
.AddAttachment Fichier
.Send
End With
End Sub
S'il vous plait çà fait plusieurs jours que je bloque dessus. Merci d'avance
Bonjour
bienvenue
je me suis envoyé un Email de votre fichier et ca fonctionne correctement!!!
merci de nous informer du probleme
cordialement
a vous relire
Il manquait 2 feuilles dans mon fichier je l'ai remis a jour.
re
je pense que le fichier fonctionne correctement!!!
je pense que vous avez reçu un email ou les 3 feuilles apparaisses
a vous relire
Le problème est que je voudrai envoyé qu'une seule de ces feuilles et non le classeur
bonjour
désolé pour le retard
j'avais pas mon fichier chez moi, mais seulement au bureau
Option Explicit
Public Sub CDO_Mail1_ActiveSheet()
Dim wbSource As Workbook, wbNew As Workbook
Dim FileExtStr As String, TempFilePath As String, TempFileName As String
Dim FileFormatNum As Long
Dim iMsg As Object, iConf As Object
Dim Flds As Variant
Dim signature As String
'EMAIL recap jour
If MsgBox("Etes-vous certain de vouloir envoyer cette email ?", vbQuestion + vbYesNo, _
"Demande de confirmation") <> vbYes Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wbSource = ActiveWorkbook
' Copie la feuille active dans un nouveau classeur.
ActiveSheet.Copy
ActiveSheet.Range("A5:A20") = wbSource.Sheets("RECAP JOUR").Range("A5:A20").Value
ActiveSheet.Range("B5:B20") = wbSource.Sheets("RECAP JOUR").Range("B5:B20").Value
ActiveSheet.Range("C5:C20") = wbSource.Sheets("RECAP JOUR").Range("C5:C20").Value
ActiveSheet.Range("D5:D20") = wbSource.Sheets("RECAP JOUR").Range("D5:D20").Value
ActiveSheet.Range("E5:E20") = wbSource.Sheets("RECAP JOUR").Range("E5:E20").Value
ActiveSheet.Range("F5:F20") = wbSource.Sheets("RECAP JOUR").Range("F5:F20").Value
ActiveSheet.Range("G5:G20") = wbSource.Sheets("RECAP JOUR").Range("G5:G20").Value
ActiveSheet.Range("H5:H20") = wbSource.Sheets("RECAP JOUR").Range("H5:H20").Value
ActiveSheet.Range("I5:I20") = wbSource.Sheets("RECAP JOUR").Range("I5:I20").Value
ActiveSheet.Range("J5:J20") = wbSource.Sheets("RECAP JOUR").Range("J5:J20").Value
ActiveSheet.Range("K5:K20") = wbSource.Sheets("RECAP JOUR").Range("K5:K20").Value
ActiveSheet.Range("L5:L20") = wbSource.Sheets("RECAP JOUR").Range("L5:L20").Value
ActiveSheet.Range("M5:M20") = wbSource.Sheets("RECAP JOUR").Range("M5:M20").Value
' Ou si vous voulez copier plusieurs feuilles. Utilisez :
' wbSource.Sheets(Array("Sheet1", "Sheet3")).Copy
ActiveSheet.Shapes.Range(Array("bouton1")).Select 'Efface le bouton d'envoie
Selection.Delete
Set wbNew = ActiveWorkbook
' On détermine la version Excel et l'extension du fichier / Format
With wbNew
If Val(Application.Version) < 12 Then
' Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
' 2007-2010
' On sort de la procédure dans le cas les macros sont désactivées.
' *** cas ou cette procédure est lancée d'un autre classeur (ex : Personal.xlsb).***
If wbSource.Name = .Name Then
Application.EnableEvents = True
MsgBox "Vous n'avez pas activé les macros."
Exit Sub
Else
Select Case wbSource.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
' Sauve le nouveau classeur, poste le message et supprime le fichier temporaire crée.
TempFilePath = Environ$("temp") & "\"
TempFileName = "Recap Jour " & wbSource.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With wbNew
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
MsgBox TempFilePath & TempFileName & FileExtStr
.Close savechanges:=False
End With
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' Source par défaut CDO
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") = "xxxxxxx@gmail.com" ' email
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxxxxxxxx" ' mot de pass
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.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
signature = "Mr xxxxxxxxxx" & vbCrLf & "Responsable xxxxxxxxx" 'changer votre nom entre les " "
.To = "xxxxxxxx@gmail.com" ' a qui on envoie
.CC = "xxxxxxx@gmail.com, xxxxxxx@gmail.com" ' pour qui la copie
.BCC = "" ' copie conforme
'.To = "" ' a qui on envoie
'.CC = "" ' pour qui la copie
'.BCC = "" ' copie conforme
.From = "xxxxxxx@gmail.com" ' de
.Subject = "xxxxxxxxxxxxxxxx" ' à modifier
.TextBody = "Bonjour," & vbCrLf & "je vous pris de bien vouloir recevoir le mail de la recap du jour," & vbCrLf & "cordialement" & vbCrLf & signature 'à modifier
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
Range("L2:L3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65280
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Supprime le fichier envoyé.
Kill TempFilePath & TempFileName & FileExtStr
Application.EnableEvents = True
Set Flds = Nothing
Set iConf = Nothing
Set iMsg = Nothing
Set wbNew = Nothing: Set wbSource = Nothing
End Sub
cette macro fonctionne chez moi depuis 2 ans déjà
il n'y a qu'a changer les nom et titre et destinataire
aussi tu peu paramétrer les cellules a envoyer .
j'espere que ca vous aideras
a vous relire en cas de probleme
Bonjour,
ça marche nickel.
Un énorme MERCI pour ce code qui m'a permis de comprendre un peu plus le VBA et de rendre fontionnel le classeur que je partage avec mes collègues.