Pièce jointe mail

Hello à tous,

Pouvez-vous m'aider car mon code ne fonctionne plus !

La pièce jointe ne s'envoie plus ?!

Private Sub CommandButton1_Click()

Dim Fichier As String

Dim TEXTE As String

Dim Sh As Variant

Dim cp As Variant

Dim Plage As Range

Application.ScreenUpdating = False

'TEXTE = Range("J3")

TEXTE = Replace(Replace(Sheets("RDP").Range("J3").Value, "/", "."), ":", "H")

Application.ThisWorkbook.Saved = True

On Error Resume Next

Application.OnTime tps, Procedure:="GuidoNow", Schedule:=False

Set tps = Nothing

Fichier = "C:\Users\ABENMOUSSA\Desktop\Dossier\RDP " 'à adapter

'ActiveSheet.PageSetup.PrintArea = ("A1:J" & Range("A65536").End(xlUp).Row)

On Error Resume Next

Set Sh = ActiveSheet

With Sh

Set Plage = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 10)

End With

Plage.ExportAsFixedFormat Type:=xlTypePDF, _

Filename:=Fichier & TEXTE, _

Quality:=xlQualityStandard, _

IncludeDocProperties:=True, _

IgnorePrintAreas:=False, _

OpenAfterPublish:=False

Sheets.Add After:=Sheets(Sheets.Count)

ActiveWorkbook.EnvelopeVisible = True

With ActiveSheet.MailEnvelope

For cp = .Item.Attachments.Count To 1 Step -1

.Item.Attachments(cp).Delete

Next cp

.Item.To = "ali.benmoussa@disney.com"

.Item.Subject = "Chiffres Pandora"

.Introduction = " Hello tout le monde," & vbCrLf & vbCrLf & "Ci-joint les chiffres Pandora" & vbCrLf & vbCrLf & "Cordialement," & vbCrLf & vbCrLf & "Team Legends"

.Item.Attachments.Add Fichier

.Item.Send

End With

Application.DisplayAlerts = False

ActiveSheet.Delete

Sh.Activate

Application.ScreenUpdating = True

End Sub

Merci d'avance

Setila