Private Sub CommandButton1_Click()
Dim Chemin As String, PDFName As String
' Initialisation des variables
Chemin = "C:\"
PDFName = Range("H10").Value
' Copie de la feuille et impression en PDF
ActiveSheet.Copy
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & PDFName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
' Envoi du fichier par mail via CDO
On Error Resume Next
CDO_Mail Chemin, PDFName
If Err.Number <> 0 Then
MsgBox "Un problème est survenu lors de la tentativs d'envois"
Else
MsgBox "Votre feuille a bien été envoyé"
End If
On Error GoTo 0
' Fermer le classeur créer temporairement
ActiveWorkbook.Close SaveChanges:=False
End Sub
Sub CDO_Mail(Chemin As String, FicPDF As String)
' From [url=http://www.rondebruin.nl/cdo.htm]Sending mail from Excel with CDO[/url]
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant
' Tester l'antislash de fin du chemin
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
' Avec l'application
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Créer l'objet CDO
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Mettre le serveur SMTP ici"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = MailAdresse
.CC = ""
.BCC = ""
.From = "toto <[EMAIL="toto@free.fr"]toto@free.fr[/EMAIL]>"
.Subject = MailSubject
.TextBody = "Veuillez trouvez ci-joint"
.AddAttachment Chemin & FicPDF
.Send
End With
' Supprimer le fichier PDF qui a été créé (si on souhaite le supprimer)
Kill Chemin & FicPDF
' Avec l'application
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub