Envoyer une feuille de mon classeur par mail en pièce jointe

Le 01/08/2016 à 15:39

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

124j1.xlsm (21.23 Ko)
Le 01/08/2016 à 15:48

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

Le 01/08/2016 à 16:55

Il manquait 2 feuilles dans mon fichier je l'ai remis a jour.

Le 01/08/2016 à 17:47

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 01/08/2016 à 18:33

Le problème est que je voudrai envoyé qu'une seule de ces feuilles et non le classeur

Le 02/08/2016 à 10:01

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

Le 20/05/2017 à 14:11

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.

Rechercher des sujets similaires à "envoyer feuille mon classeur mail piece jointe"