XL 2010 Envoi d'une feuille spécifique par mail via VBA

[Saumon80]

Bonjour,

J'utilise le code suivant pour envoyer par email le classeur actif contenant la macro.

Private Sub Mail_workbook_Outlook_2()
'Mail a copy of the ActiveWorkbook with another file name
    Dim wb1 As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileNameStr As String
    Dim OutApp As Object
    Dim OutMail As Object

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

    Set wb1 = ActiveWorkbook
  
    FileNameStr = Range("AT1").Value

    'Make a copy of the file/Open it/Mail it/Delete it
    'If you want to change the file name then change only TempFileName
    TempFilePath = Environ$("temp") & "\"
    TempFileName = FileNameStr
    FileExtStr = ".xlsm"

     wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr

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

    On Error Resume Next
    With OutMail
    
        .to = Range("ah2") & ";" & Range("ah3") & ";" & Range("ah4")
        .CC = Range("AO11")
        .BCC = Range("AO5") & ";" & Range("al5")
        .Subject = ""
        .Body = ""
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

   'Delete the file
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Comment puis je le modifier pour n'envoyer que la feuille ou l'onglet actif?

Merci beaucoup

 

[Lone-wolf]

Bonjour Saumon et bonne année

Il faut remplacer Workbook par:

Sheets("Feuil1").Activate
Activesheet.Copy
Activesheet.SaveAs Filename:= TempFilePath & "Donnees.xlsm" , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close True

 

[Saumon80]

Merci beaucoup Lone-Wolf ! et bonne et heureuse année a toi aussi

Te serait-il possible de modifier directement le code dans mon message original en me disant ou ajouter ces lignes et lesquelles je dois supprimer?
Je suis débutant sur VBA et pas trop sur de quelles lignes modifier.

Dim wb1 As Workbook

Set wb1 = ActiveWorkbook

Je dois mofifier a ces 2 endroits?

wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr

Et cette ligne aussi ?

Merci beaucoup pour ton aide

 

[Lone-wolf]

Re

Noms des feuilles à modifier.

Option Explicit

Dim i As Long, cel As Range, Chemin As String, Nom As String
Dim CCMail, BCCMail, AdressMail, CopieC, Strcc

Sub Envoi_Mail()
Dim olApp As Outlook.Application
Dim olMail As MailItem

  With Sheets(1)
  CCMail = .Range("AO11")
  BCCMail = .Range("AO5") & ";" & .Range("al5")
  End With

 
  Chemin = Environ$("temp") & "\"
  Nom = "Courrier Outlook" & ".xlsm"
 
  Sheets(2).Activate
  With ActiveSheet
  .Copy
  .SaveAs Filename:=Chemin & Nom, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
  ActiveWorkbook.Close True
  End With

  On Error GoTo ErrHandler
  For Each cel In Sheets(1).Range([AH2], Sheets(1).[AH65536].End(xlUp))
  Strcc = Strcc & cel.Value & ";"
  Next cel
  CopieC = Split(Strcc, ";")

  For i = 0 To UBound(CopieC) - 1
  If CopieC(i) = AdressMail Then
  Exit For
  Else
  AdressMail = AdressMail & CopieC(i) & ";"
  End If
  Next i
ErrHandler:


  Set olApp = CreateObject("Outlook.Application")
  Set olMail = olApp.CreateItem(olMailItem)

  With olMail
  .To = Mid(AdressMail, 1, Len(AdressMail) - 1)
  .CC = CCMail
  .BCC = BCCMail
  .Subject = ""
  .HTMLBody = ""
  .Attachments.Add Chemin & Nom
  .Display
  End With

  Set olMail = Nothing
  Set olApp = Nothing
  Kill Chemin & Nom
End Sub

 

[Saumon80]

Bonjour Lone-Wolf,

Merci beaucoup pour ton aide.
Je joint le fichier que j'utilise pour test.

J'ai essaye d'utiliser le code que tu m'a transmis mais ,le message suivant s'affiche Compile error : User defined-type not defined. Et la ligne Sub envoi mail devient jaune,

Dois je modifier des réglages?

Merci beaucoup

 

[Lone-wolf]

Bonjour Saumon

ça doit être le chemin qui cause problème. Modifie-le en mettant le chemin exacte "C:\Users\Saumon\App Data\Local\Temp\" c'est un exemple.

 

[Saumon80]

Merci Lone-Wolf .
Desole de t'embeter encore mais j'ai maintenant le message "expected line number or label or statement or end of statement".
Peut-etre que je dois activer certaines references dans VBA ?

Autrement tu pense que cela peut aussi marcher modifiant workbook dans le code originel present dans le fichier en piece jointe ?

 

[Lone-wolf]

Bonsoir Saumon

Entre nous, pourquoi te ne teste pas le code que j'ai mis au lieu de te casser la tête avec le tiens???

Pour l'envois outlook il faut cocher la référence microsoft outlook 14.0 object library; active aussi microsoft html object library.

 

[Saumon80]

Mea culpa ,je vais utiliser le code que tu m'a fourni, je ne comprenait pas ce qui ne fonctionnait pas mais après avoir activé les référence que tu m'a indiqué j'avance lentement mais surement et je pense semble être proche du but.

Cependant j'ai encore un probleme, une fois que la fenêtre Outlook s'ouvre je reçois le message "Permission refusée" et tout le classeur est envoyé et non pas juste la feuille active.

Pourrait tu essayer ton code dans le fichier que j'ai joint et me dire si cela marche pour toi ?

 

[Lone-wolf]

Bonjour Saumon

Le code à été testé sans problèmes. Supprime l'envois outlook. Test juste la copie de la feuille. Parce-que le code dit: copie la feuille(et non tout le classeur).