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