envoie par mail la fuille active en EXCEL + PDF

[AWB]

Bonjour à tous,

j'ai un code qui me permet d'envoyer sous format pdf la fuille active, je souhaite joindre aussi la fuille active en EXCEL.

merci de votre aide :

Sub mail()
'Fonctionne sous excel 2000-2013
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim S As Shape
Dim chemin As String
chemin = "\\f-aker\home1$\ax19597\MyDocs\Facture r?cap Renault SAS\"
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copie la feuille active comme nouvelle feuille
ActiveSheet.Copy
Set destwb = ActiveWorkbook

'D?sactiver fen?tre de compatibilit?
Application.DisplayAlerts = False
'----------------------------------------------------------------------------
'Sauvegarde la nouvelle feuille/L'envoie par mail/La supprime
'----------------------------------------------------------------------------
TempFilePath = Environ$("temp") & "\"
TempFileName = (ActiveSheet.Name & " " & Format(Date, "ddmmyy") & "_" & Format(Time, "hhmmss"))
Set OutApp = CreateObject("outlook.application")
Set OutMail = OutApp.CreateItem(0)

With destwb
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & TempFileName & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' sauvegarde du fichier au format pdf
On Error Resume Next
With OutMail
.To = "ab@ab.com"
.CC = "ab@ab.com"
.bcc = ""
.Subject = "sujet du mail"
.Attachments.Add TempFilePath & TempFileName & ".pdf"
.Body = "Bonjour Si Abid" & vbCr & "Tu Trouveras ci-joint la facture d'importation numero " & TempFileName & vbCr & "Cordialement" & vbCr & "Hamza"
'.display 'ou alors utiliser
.Send 'pour envoi
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Effacer le fichier envoy?
Kill TempFilePath & TempFileName & ".pdf"
Set OutMail = Nothing
Set OutApp = Nothing

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

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
chemin & (ActiveSheet.Name & " " & Format(Date, "ddmmyy") & "_" & Format(Time, "hhmmss")) & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End Sub

 

[Compte Supprimé 979]

Bonjour AWB,

Voici le code corrigé

Option Explicit

Sub mail()
  'Fonctionne sous excel 2000-2013
  Dim FileExtStr As String
  Dim FileFormatNum As Long
  Dim Sourcewb As Workbook
  Dim DestWbk As Workbook
  Dim TempFilePath As String
  Dim TempFileName As String
  Dim OutApp As Object
  Dim OutMail As Object
  Dim S As Shape
  Dim chemin As String
  chemin = "\\f-aker\home1$\ax19597\MyDocs\Facture r?cap Renault SAS\"
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
  Set Sourcewb = ActiveWorkbook
  'Copie la feuille active comme nouvelle feuille
  ActiveSheet.Copy
  Set DestWbk = ActiveWorkbook
  'D?sactiver fen?tre de compatibilit?
  Application.DisplayAlerts = False
  '----------------------------------------------------------------------------
  'Sauvegarde la nouvelle feuille/L'envoie par mail/La supprime
  '----------------------------------------------------------------------------
  TempFilePath = Environ$("temp") & "\"
  TempFileName = (ActiveSheet.Name & " " & Format(Date, "ddmmyy") & "_" & Format(Time, "hhmmss"))
  ' Sauvegarder le classeur de la feuille
  DestWbk.SaveAs TempFilePath & TempFileName & ".xlsx"
  '
  Set OutApp = CreateObject("outlook.application")
  Set OutMail = OutApp.CreateItem(0)
 
  DestWbk.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & TempFileName & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False ' Exporte le fichier au format pdf
    On Error Resume Next
    With OutMail
      .To = "ab@ab.com"
      .CC = "ab@ab.com"
      .bcc = ""
      .Subject = "sujet du mail"
      .Attachments.Add TempFilePath & TempFileName & ".pdf"
      .Attachments.Add TempFilePath & TempFileName & ".xlsx"
      '
      .Body = "Bonjour Si Abid" & vbCr & "Tu Trouveras ci-joint la facture d'importation numero " & TempFileName & vbCr & "Cordialement" & vbCr & "Hamza"
      '.display 'ou alors utiliser
      .Send 'pour envoi
    End With
    On Error GoTo 0
  DestWbk.Close SaveChanges:=False
  'Effacer le fichier envoy?
  Kill TempFilePath & TempFileName & ".*"
  Set OutMail = Nothing
  Set OutApp = Nothing
 
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
End Sub

A+

 

[AWB]

Merciii infiniment, c'est parfait