Envoyer onglet actif par e-mail

Salut à tous

Je débute avec Excel VBA et j'ai besoin de votre aide pour m'aider à peaufiner mon code actuel....

Voilà plusieurs semaines que je teste des codes trouvés sur les forum mais je ne parvient pas à mes fins

En pièce jointe, je vous ai mis mon document. Je souhaite créer un bouton E-mail qui me permettra d'envoyer uniquement l'onglet actif en pièce jointe par le biais de Microsoft Outlook 2010.

J'ai trouvé un code qui me permet de le faire mais j'aimerai que le nom du classeur soit identique à celui de l'onglet.

Par exemple, sur l'onglet "Sophie", j'aimerais que l'onglet mis en pièce joint se nomme Sophie.xls

Dans mon classeur, j'ai aussi un onglet Mail avec le sujet en B1 et le texte en D1 que je souhaite intégrer automatiquement à l'envoi de mon e-mail. L'adresse du destinataire se trouve sur l'onglet actif en C1.

Voici mon code, il est tout simple mais ne me permets pas d'effectuer tout ce que je viens de citer ci-dessus

Sub envoi_mail()

ActiveSheet.Copy

ActiveWorkbook.SendMail Recipients:="xxx@monadresse"

ActiveWorkbook.Close savechanges:=False

End Sub

Merci infiniment pour votre aide je me réjouis de vous lire!!

Belle soirée à tous

Sophie

Bonjour Sophie,

Voici le code (si tu veux le format xls au lieu du format xlsx tu auras un fichier plus lourd et la perte de certaines caractéristiques par rapport à l’original, tu peux quand même adapter le code):

Sub mail()

    Dim Ws     As Worksheet
    Dim WsMail As Worksheet
    Dim NewWbk    As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Adresse As String, Sujet As String, Message As String
    Dim FilePath As String
    Dim FileName As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Ws = ActiveSheet
    Set WsMail = Sheets("Mail")
    Adresse = Ws.Range("C1").Value
    Sujet = WsMail.Range("B1").Value
    Message = WsMail.Range("D1").Value

    FilePath = Environ$("temp") & "\"
    FileName = Ws.Name
    Ws.Copy
    Set NewWbk = ActiveWorkbook
    With NewWbk
        .SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls

        On Error Resume Next
        With OutMail
            .To = Adresse
            .CC = ""
            .BCC = ""
            .Subject = Sujet
            .Body = Message
            .Attachments.Add NewWbk.FullName
            .Display
            ' .Send 'Pour envoi automatique
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill FilePath & FileName & ".xlsx" ' ".xls"
    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True

    End With

End Sub

FANTASTIQUE !!!! Merci Sequoyah tu es un chef, ça fonctionne à merveille et c'est exactement ce que je voulais!!!!

Trop trop bien, merci infiniment pour ton aide et pour le temps que tu as passé pour la création de ce code! C'est parfait!!!

Tu sais me dire s'il y a une possibilité avec ce code pour qu'il se répète en boucle sur tous les onglets?

Genre un bouton mail, qui va faire onglet par onglet en boucle (mais pas les 6 premiers onglets, uniquement à partir de l'onglet 7) et que ça prépare le mail comme le code que tu viens de me taper mais pour tous les onglets en même temps, chacun dans un email bien distinct? J'abuse mais merci à toi si tu as encore cette petite solution pour moi

Excellente soirée et au plaisir de te lire

Sof

Bonjour Sophie,

merci pour ton retour, voici le code modifié:

Sub mail2()

    Dim Ws     As Worksheet
    Dim WksCount As Integer
    Dim i As Integer
    Dim WsMail As Worksheet
    Dim NewWbk    As Workbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Adresse As String, Sujet As String, Message As String
    Dim FilePath As String
    Dim FileName As String

WksCount = ActiveWorkbook.Worksheets.Count

For i = 7 To WksCount

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Ws = Sheets(i)
    Set WsMail = Sheets("Mail")
    Adresse = Ws.Range("C1").Value
    Sujet = WsMail.Range("B1").Value
    Message = WsMail.Range("D1").Value

    FilePath = Environ$("temp") & "\"
    FileName = Ws.Name
    Ws.Copy
    Set NewWbk = ActiveWorkbook
    With NewWbk
        .SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls

        On Error Resume Next
        With OutMail
            .To = Adresse
            .CC = ""
            .BCC = ""
            .Subject = Sujet
            .Body = Message
            .Attachments.Add NewWbk.FullName
            .Display
            ' .Send 'Pour envoi automatique
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill FilePath & FileName & ".xlsx" ' ".xls"

     Next i

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True

    End With

End Sub

P.S.

Si le sujet et le message ne changent pas on pourrait les insérer directement dans le code sans besoin d'utiliser une feuille separée.

trop biennnnnnnnnnnnnnn!!!! Encore une fois, tu as assuré!!! Je te remercie infiniment!!!!

Oui alors le text est le même pour tous les e-mails mais il faut que même un novice puisse

l'adapter du coup, c'est plus simple de pouvoir le modifier sur un onglet excel mais

rassure-toi, je risque d'avoir de nouvelles demandes

Merci merci merci pour ton travail, tu m'es d'une aide incroyable, c'est trop cool!!!!

Oh Sequoyah, j'ai encore besoin de tes lumières

Ah non j'ai réussi C'est tout bon, oublie ce post!!! Encore merci pour tout ce que tu as fait pour moi!!!

Ma question était concernant les onglets que je souhaitais transmettre, je voulais supprimer les boutons de la feuille et la bloquer le nouvel onglet avec un mot de passe mais finalement j'ai bidouillé 4308532495 codes pour arriver au résultat espéré :

FilePath = Environ$("temp") & "\"

FileName = Ws.Name

Ws.Copy

Set NewWbk = ActiveWorkbook

With NewWbk

Dim w As Worksheet

For Each w In NewWbk.Sheets

w.Buttons.Delete

w.Protect Password:="000000", AllowFiltering:=True

Next

.SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls

Salut Sequoyah & les pro d'Excel,

Mon code fonctionne parfaitement, mais je me rends compte d'un détail... J'aimerais que dans mon code actuel, s'il n'y a pas d'entrée en A12, alors il ne faut pas envoyer l'onglet mais passer au suivant etc... Juste mettre cette dernière option, quelqu'un arriverait à me trouver la solution?

Merci d'avance pour votre précieuse aide!!

Sophie

Sub envoionglet()

Dim Ws As Worksheet

Dim WksCount As Integer

Dim i As Integer

Dim WsMail As Worksheet

Dim NewWbk As Workbook

Dim OutApp As Object

Dim OutMail As Object

Dim Adresse As String, Sujet As String, Message As String

Dim FilePath As String

Dim FileName As String

WksCount = ActiveWorkbook.Worksheets.Count

For i = 6 To WksCount

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

With Application

.DisplayAlerts = False

.ScreenUpdating = False

.EnableEvents = False

End With

Set Ws = Sheets(i)

Set WsMail = Sheets("Mail")

Adresse = Ws.Range("C1").Value

Sujet = WsMail.Range("B1").Value

Message = WsMail.Range("D1").Value

FilePath = ThisWorkbook.Path & "\"

FileName = Ws.Name

Ws.Copy

Set NewWbk = ActiveWorkbook

With NewWbk

Dim w As Worksheet

For Each w In NewWbk.Sheets

w.Buttons.Delete

w.Protect Password:="000000", AllowFiltering:=True

Next

.SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls

On Error Resume Next

With OutMail

.To = Adresse

.CC = ""

.BCC = ""

.Subject = Sujet

.Body = Message

.Attachments.Add NewWbk.FullName

.Display

' .Send 'Pour envoi automatique

End With

On Error GoTo 0

.Close savechanges:=False

End With

'Kill FilePath & FileName & ".xlsx" ' ".xls"'

Next i

Set OutMail = Nothing

Set OutApp = Nothing

With Application

.DisplayAlerts = False

.ScreenUpdating = True

.EnableEvents = True

End With

End Sub

Bonjour Sophie,

heureux de te revoir .

Voici le code modifié selon ta demande, à verifier si la boucle doit partir du sixième ou du septième onglet.

Sub mail3()

    Dim WsMail As Worksheet, wks As Worksheet, newWks As Worksheet
    Dim OutApp As Object, OutMail As Object
    Dim Adresse As String, Sujet As String, Message As String
    Dim i      As Integer
    Dim dos    As String                          'déclare la variable dos (chemin d'accès)
    Dim Fichier As String

    dos = ThisWorkbook.Path & "\"                 'définit la variable dos
    Set WsMail = Sheets("Mail")

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    For i = 7 To ThisWorkbook.Worksheets.Count
    If Not IsEmpty(Sheets(i).Range("A12")) Then

        Sheets(i).Copy
        Set newWks = ActiveSheet
        Fichier = dos & newWks.Name & ".xlsx"

        Adresse = newWks.Range("C1").Value
        Sujet = WsMail.Range("B1").Value
        Message = WsMail.Range("D1").Value

        With newWks
            .Buttons.Delete
            .Protect Password:="000000"
            .Parent.SaveAs FileName:=Fichier, _
                           FileFormat:=xlOpenXMLWorkbook
            .Parent.Close savechanges:=False
        End With

        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next

        With OutMail
            .To = Adresse
            .CC = ""
            .BCC = ""
            .Subject = Sujet
            .Body = Message
            .Attachments.Add Fichier
            .Display
            ' .Send 'Pour envoi automatique
        End With
        On Error GoTo 0

        Kill Fichier

        End If
    Next

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True

    End With

End Sub

Oh Sequoyah,

J'espérais que ce soit toi qui me réponde!!!

Trop bien, comme toujours!!! Ton code fonctionne du tonner

Je ne sais plus comment te remercier tellement de fois tu m'as aidée!!!

UN ÉNORME MERCIIIII