Macro envoi par mail : pbm

Bonjour,

J'utilise une macro pour l'envoi par mail d'une plage définie dans une feuille excel.

J'ai deux problèmes :

1) la mise en page de la feuille envoyée par mail n'est pas tout à fait la même que celle de départ, et je perd la zone d'impression (une seule zone d'impression pour la plage)

2) j'a créée sur la même feuille une autre plage, pour pouvoir l'envoyer par mail via un deuxième bouton et via une deuxième macro (macro Envoi_BC2_par_mail()) identique à la première, j'ai juste changé les coordonnées des cellules ! , mais dans le mail, pas de destinataire, pas de CC, rien, seulement le fichier joint (qui est bien le bon).

Je ne comprends pas pourquoi ça ne marche pas.... Avez vous une idée ?

Ci joint le scritp de la 1ere macro :

Sub Envoi_BC1_par_mail()
 ActiveSheet.Unprotect "xxxx"
'Working in 2000-2010
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    On Error Resume Next
    Set Source = Range("A1:AE72").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = Range("E2").Value & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

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

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = Range("AD1").Value
            .CC = Range("AD2").Value
            .BCC = Range("AD3").Value
            .Subject = Range("AD4").Value
            .Body = Range("AD5").Value
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
 ActiveSheet.Protect "xxxx"
End Sub

La deuxième macro :

Sub Envoi_BC2_par_mail()
 ActiveSheet.Unprotect "xxxx"
'Working in 2000-2010
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    On Error Resume Next
    Set Source = Range("A201:AE272").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = Range("E202").Value & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

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

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = Range("AD201").Value
            .CC = Range("AD202").Value
            .BCC = Range("AD203").Value
            .Subject = Range("AD204").Value
            .Body = Range("AD205").Value
            .Attachments.Add Dest.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
 ActiveSheet.Protect "xxxx"
End Sub

voici un fichier joint pour une meilleur compréhension du pbm :

Bonjour

J'ai essayé plein de "trucs" sans réussir et sans comprendre.

peut-être un autre nous expliquera...

Cordialement

Bonjour,

Merci pour avoir essayé..

J'espère trouver une solution...

j'ai trouvé cette macro via ce site :

J'avais aussi remarqué qu'avec cette macro, il faut que les adresses des destinataires, le corps du mail etc, se trouvent sur la plage envoyé en pièce jointe, sinon pas d'adresse mail ni de corps de mail dans le mail !

à n'y rien comprendre...

Re, en relisant le script je crois que j'ai peut être compris :

Sub Envoi_BC1_par_mail()
 ActiveSheet.Unprotect "xxxx"
'Working in 2000-2010
   Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object

    Set Source = Nothing
    On Error Resume Next
  Set Source = Range("A1:AE72").SpecialCells(xlCellTypeVisible)
' a ce niveau là je mets A201:AE272, et puis c'est fini !  car j'ai l'impression que le reste du script fait référence au nouveau fichier créé, donc les coordonnées ne changent pas !!  Je ne peux pas essayer là car je suis sur un mac et ça ne peut pas marcher sous mac..., je dois attendre d'être au bureau sous PC lundi pour voir...

Pbm résolu : c'était bien ça le pbm

Pbm résolu : c'était bien ça le pbm