1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par mail

[Matjul]

Bonjour à tous,
J'ai télécharger PDFCreator mais je ne sais pas quel code utiliser.
En fait, je souhaiterai qu'en cliquant sur un seul bouton, toutes les actions suivantes se fassent:
- Transformer le Feuil1 en pdf
- Envoyer ce pdf par mail à des destinataires
- Enregistrer ce pdf sous la date du jour dans le dossier "C:/Récapitulatif/"
- Imprimer ce pdf

Peut importe l'ordre de réalisation pourvu que toutes ces actions se fassent.

J'ai recherché les autres fil sur ce sujet mais je n'en ai pas trouvé qui faisaient tout en même temps.

Merci beaucoup pour votre aide.

 

[kiki29]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Salut, voir et adapter à ton contexte https://www.excel-downloads.com/threads/idee-pour-creer-un-fichier-pdf-depuis-pdf-creator.78238/
https://www.excel-downloads.com/threads/feuille-excel-en-pdf.82781/
https://www.excel-downloads.com/threads/transformer-fichier-excel-en-pdf.91335/
Tu as tous les éléments pour le faire toi-même

 

[Matjul]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Bonjour,
J'avais lu ces messages, alors j'ai essayé de combiner toutes les fonctions en une seule mais cela ne fonctionne pas.
Alors est il possible de tout faire avec un seul bouton?

 

[sebastien450]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Oui, va voir sur le forum 2007 car j'avais fait un post dessus..

 

[Matjul]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Bonjour,
J'ai lu votre post, mais je n'ai pas trouvé, ou pas compris (?!?) tous les éléments que je souhaite. Entre autre transformer en pdf, enregistrer le fichier avec la date et imprimer. La seule chose que j'ai à peu près compris c'est comment envoyer par mail.
Mais comment tout faire avec un seul bouton?

 

[Matjul]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Bonjour à tous,
J'essaye d'avancer tout doucement dans mon code, j'en ai tappé un mais il ne fonctionne pas, le Voici:

Sub Envoi()

Dim CdoMessage As CDO.Message
Dim Fichier As Variant


‘ Enregistrer sous et mettre en pdf
ChDir "E:\Récapitlatif"
    ActiveWorkbook.SaveAs Filename:= _
        "E:\DOCS Récapitlatif " & Day(Date) & "." & Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & ".pdf", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
ThisWorkbook.Save

‘ Imprimer la feuille
    Worksheet("Feuil1").Select
    ActiveSheet.PageSetup.PrintArea = "Feuil1"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True


‘ Envoyer par mail

    ChDir "C E:\DOCS Récapitlatif " & Day(Date) & "." & Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & ".pdf",
    Fichier = Application.GetOpenFilename("Fichiers PDF (*.pdf), *.pdf")

    If Fichier = False Then Exit Sub

    Set CdoMessage = New CDO.Message
    With CdoMessage
        .Subject = "Exemple"
        .From = "xxxxx@wanadoo.fr"
        .To = "yyyyy@orange.fr"
        .CC = ""
        .BCC = ""
        .TextBody = "Texte dans le corps de message"
        .AddAttachment Fichier
        .Send
    End With

    Set CdoMessage = Nothing
End Sub

Je vous rappelle que je souhaiterai :
- Transformer le Feuil1 en pdf
- Envoyer ce pdf par mail à des destinataires
- Enregistrer ce pdf sous la date du jour dans le dossier "E:\Récapitulatif\"
- Imprimer ce pdf

Merci pour votre aide

 

[kiki29]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Salut,n'ayant pas de Drive en E remplacé par D, Erreurs de syntaxe corrigées,sinon le code
fonctionne sous OExpress et Outlook
Il ne suffit pas de faire du copier/coller bestial et ensuite de venir geindre sans même essayer de corriger

Option Explicit

Sub Envoi()
Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
    ChDrive "D"
    ChDir "D:\Récapitulatif"
    SNomFichier = "D:\Récapitulatif\" & Day(Date) & "." & Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier

    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "D:\Récapitulatif"
    
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    Worksheets("Feuil1").Select
    ActiveSheet.PageSetup.PrintArea = "Feuil1"
    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop

    JobPDF.cPrinterStop = False

    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    'Application.Wait Now + TimeValue("00:00:05")

    JobPDF.cClose
    Set JobPDF = Nothing

    Set CdoMessage = New CDO.Message
    With CdoMessage
        .Subject = "Exemple"
        .From = "xxxxx@wanadoo.fr"
        .To = "yyyyyy@orange.fr"
        .CC = ""
        .BCC = ""
        .TextBody = "Texte dans le corps de message"
        .AddAttachment sCheminPDF & "\" & sNomPDF
        .Send
    End With

    Set CdoMessage = Nothing
End Sub

 

[Matjul]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Bonjour et merci pour votre,
Malheureusement, j'ai essayé de me débrouillé mais je n'y arrive pas.
En fait, j'ai copier votre code et j'ai changé tous les chemins.
Je suis également allé dans Outils/Référence et j'ai activé - - Cocher PDFCreator
- Cocher Microsoft CDO for Exchange xxxx Library
J'ai essayé de comprendre ce qu'il se passe mais je ne vous cache pas que c'est difficile...

A quoi sert "Option explicit" et ou doit on le placer?

Ensuite lorsque je lance le programme, celui- ci enregistre un document avec la date du jour au format excel, mais pas pdf.
Ensuite le message suivant apparait:
"Microsoft Excel attend la fin de l'exécution d'une action OLE d'une autre application"
Or aucun autre document n'est ouvert.
Que dois je faire?
Merci pour votre aide

 

[kiki29]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Salut, tu dois avoir un process PdfCreator qui reste actif ( voir avec le taskmanager ( Ctrl+Alt+Suppr) et le killer
et valider Application.Wait Now + TimeValue("00:00:05") en enlevant le '
Personnellement sur mon PC le fichier xls est sauvé sous D:\..,l'impression lancée et le fichier Pdf sauvé dans le même répertoire, puis envoyé en PJ sans aucun probleme

Le fait qu'un process PdfCreator rest souvent actif(pas toujours) est récurrent avec PdfCreator par contre ayant aussi Acrobat Distiller ,avec ce dernier ce type de probleme n'existe pas, une des différences entre un outil professionnel et un freeware

Pour Option Explicit tu as l'aide en ligne

 

[Matjul]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Je cherche doucement ou sont mes erreurs, et maintenant, lorsque je teste le programme, le débogueur se met en route et affiche:
Erreur d'exécution 2147220960 (80040220)
La valeur de configuration "SendUsing" est non valide

Que dois je faire?
Voici le code:

Private Sub CommandButton2_Click()


Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
    ChDrive "C"
    ChDir "C:\RECAPITULATIF"
    SNomFichier = "C:\RECAPITULATIF\" & Day(Date) & "." & Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier

    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "C:\RECAPITULATIF"
    
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    Worksheets("Saisie").Select
    ActiveSheet.PageSetup.PrintArea = "A1:AZ42"
    ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop

    JobPDF.cPrinterStop = False

    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    Application.Wait Now + TimeValue("00:00:05")

    JobPDF.cClose
    Set JobPDF = Nothing

    Set CdoMessage = New CDO.Message
    With CdoMessage
        .Subject = "Disponibilité journanlière "
        .From = "XXXXX@XXXX.fr"
        .To = "XXXXX@XXXXX.fr"
        .CC = ""
        .BCC = ""
        .TextBody = "Bonjour, Veuillez trouver ci-joint les disponibilités du CODIS 24 pour la journée du  " & TextBox1.Value
        
        .AddAttachment sCheminPDF & "\" & sNomPDF
        .Send
    End With

    Set CdoMessage = Nothing

End Sub

Merci

 

[kiki29]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Si tu es en réseau sur un serveur il y a qqs lignes à ajouter
voir sur Ce lien n'existe plus
Je n'ai plus de serveur de dispo et donc ne peux tester ce cas,désolé

 

[Matjul]

Re : 1 bouton pour enregistrer une feuille sous.. la transformer en pdf l'envoyer par

Ok c'est bon tout fonctionne, merci beaucoup!!

 

[Matjul]

Envoyer un mail avec un serveur exchange.

Bonjour à tous,
Je pensais avoir résolu mon problème mais un bug persiste.

Avec le code suivant, j'arrive à créer un pdf, l'enregistrer dans un dossier, et envoyer un mail avec la pièce jointe, mais en interne uniquement.
Dès que je veux envoyer le mail sur une autre messagerie, xxxx@free.fr par exemple, le débogueur se met en route et m'indique:
Erreur d'exécution '-2147220977 (8004020f)':
Le serveur a rejeté une ou plusieur adresse de destinataire. La réponse du serveur était : 550 5.7.1 Unable to relay for xxxxxx@free.fr

Voici le code:

Dim CdoMessage As CDO.Message
Dim SNomFichier As String
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim objMessage
    ChDrive "C"
    ChDir "C:\RECAPITULATIF"
    SNomFichier = "C:\RECAPITULATIF\" & Day(Date) & "." & Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & ".xls"
    ActiveWorkbook.SaveCopyAs Filename:=SNomFichier

    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "C:\RECAPITULATIF"
    
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
            MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    Worksheets("Saisie").Select
    ActiveSheet.PageSetup.PrintArea = "A1:AZ42"
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"

    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop

    JobPDF.cPrinterStop = False

    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    Application.Wait Now + TimeValue("00:00:05")

    JobPDF.cClose
    Set JobPDF = Nothing

    
' On Error Resume Next
        '.Send
'If Err Then MsgBox "Le message n'a pas pu être expédié."
'On Error GoTo 0

    'End With

    'Set CdoMessage = Nothing
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Disponibilité journalière "
objMessage.From = "xxxxxxxx@sdisxx.fr"
objMessage.To = "xxxxxxxxx@free.fr"
objMessage.TextBody = "Bonjour, Veuillez trouver ci-joint les disponibilités du pour la journée du " & TextBox1.Value

objMessage.AddAttachment sCheminPDF & "\" & sNomPDF
'==This section provides the configuration information for the remote SMTP server.
'==Normally you will only change the server name or IP.
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2

'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "server-exch.SDISxx.FRX"

'Server port (typically 25)
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

objMessage.Configuration.Fields.Update


         objMessage.Send

Merci pour votre aide

 

[Matjul]

Envoyer un mail avec pièce jointe en pdf

Bonjour à tous,
Je suis toujours avec mon problème d'envoie de mail avec un pdf en pièce jointe.
J'ai revu totalement le code et notamment celui pour envoyer le mail, puisque ce dernier fonctionnait très bien en messagerie intranet, mais pas lorsque j'envoyais le message à l'extérieur.

J'arrive donc bien à créer un pdf et l'enregistrer dans C:
J'arrive également à envoyer un mail à l'extérieur avec la pièce jointe en xls, mais je n'arrive pas à envoyer la mail avec le fichier pdf en pièce jointe, et c'est ce que je souhaiterai faire.

Voici le code dans un userform1

Const Recipient = "xxxxxxxxx@free.fr" ' Adresse email ou non du contact Exchange


Private Sub CommandButton2_Click()


    Dim SNomFichier As String
    Dim JobPDF As Object
    Dim sNomPDF As String
    Dim sCheminPDF As String
    Dim tabFiles(1) As String
    ChDrive "C"
    ChDir "C:\RECAPITULATIF"
    SNomFichier = "C:\RECAPITULATIF\" & Day(Date) & "." & Month(Date) & "." & Year(Date) & " " & Hour(Time) & "-" & Minute(Time) & ".xls"
    'ActiveWorkbook.SaveCopyAs Filename:=SNomFichier

    sNomPDF = Right(SNomFichier, Len(SNomFichier) - InStrRev(SNomFichier, "\"))
    sNomPDF = Left(sNomPDF, Len(sNomPDF) - 3) & "pdf"
    sCheminPDF = "C:\RECAPITULATIF"
    
    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")

    With JobPDF
        If .cStart("/NoProcessingAtStartup") = False Then
           MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
            Exit Sub
        End If
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
        .cOption("AutosaveFormat") = 0
        .cClearCache
    End With

    Worksheets("Saisie").Select
    ActiveSheet.PageSetup.PrintArea = "A1:AZ42"
    ActiveSheet.PrintOut Copies:=1, ActivePrinter:="PDFCreator"

    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop

   JobPDF.cPrinterStop = False
'
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    Application.Wait Now + TimeValue("00:00:05")

    JobPDF.cClose
    Set JobPDF = Nothing
 
    

    ActiveWorkbook.Save
    tabFiles(0) = ActiveWorkbook.FullName

    Module1.sendMail Recipient, "Bonjour, Veuillez trouver ci-joint les disponibilités  " & vbCrLf & vbCrLf & "Regards" & vbCrLf & "Sent: " & Now(), tabFiles

Et voici le code dans le module1:

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Function GetWorkingFolder() As String
    GetWorkingFolder = WorkingFolder
End Function

Public Sub sendMail(Recipient As String, message As String, tabFiles() As String)
    Dim objSession As Object
    Dim objMessage As Object
    Dim objRecipient As Object
    Dim objAttachments As Object
    Dim lpBuff As String * 1024
    Dim Login As String
    Dim fso As Object
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Recipient = "" Then
        MsgBox ("Impossible d'envoyer le mail !")
        Exit Sub
    End If

    GetUserName lpBuff, Len(lpBuff)
    Login = Left$(lpBuff, (InStr(1, lpBuff, vbNullChar)) - 1)
    lpBuff = ""
    Set objSession = CreateObject("mapi.session")
   
    On Error Resume Next
    objSession.Logon "", "", False, False
    If Err.Number <> 0 Or objSession.CurrentUser = "Unknown" Then
        Err.Clear
        Set objSession = Nothing
        Set objSession = CreateObject("mapi.session")
        objSession.Logon profileName:=Login
        If Err.Number <> 0 Or objSession.CurrentUser = "Unknown" Then
            MsgBox ("Impossible d'envoyer le message. Ouvrir Outlook et essayer une nouvelle fois.")
            Exit Sub
        End If
    End If
    On Error GoTo 0
   
    Set objMessage = objSession.Outbox.Messages.Add
    objMessage.Subject = "Disponibilité du " & UserForm1.TextBox1.Value
    objMessage.Text = message
   
    ' Add files as attachement
    Set objAttachments = objMessage.Attachments
    For i = LBound(tabFiles) To UBound(tabFiles)
        If Not (IsNull(tabFiles(i)) Or tabFiles(i) = "") Then
            ' Test file exist
            If fso.fileexists(tabFiles(i)) Then
                ' Add attachement
                objAttachments.Add Right(tabFiles(i), Len(tabFiles(i)) - InStrRev(tabFiles(i), "\")), 0, , tabFiles(i)
            End If
        End If
    Next
         
   
    Set objRecipient = objMessage.Recipients.Add
    objRecipient.Name = Recipient
    objRecipient.Resolve
   
    objMessage.Fields.Add &H59020003, 1
    objMessage.Update
   
    objMessage.Send showdialog:=False
    objSession.Logoff
End Sub

Merci pour votre aide

 

[Matjul]

Envoyer un mail avec pièce jointe en pdf

Bonjour, Je rencontre toujours la même difficulté, à savoir que le fichier que j'envoie en pièce jointe n'est pas le fichier PDF, mais le classeur au format XLS.
Alors j'essaye de comprendre comment fonctionne le code.
Je pense que mon problème vient de ce bout de code qui est dans le module 1 à savoir:

' Add files as attachement
    Set objAttachments = objMessage.Attachments
    For i = LBound(tabFiles) To UBound(tabFiles)
        If Not (IsNull(tabFiles(i)) Or tabFiles(i) = "") Then
            ' Test file exist
            If fso.fileexists(tabFiles(i)) Then
                ' Add attachement
                objAttachments.Add Right(tabFiles(i), Len(tabFiles(i)) - InStrRev(tabFiles(i), "\")), 0, , tabFiles(i)
            End If
        End If
    Next

Pouvez vous m'expliquer comment fonctionne ce code, afin d'essayer de me dépatouiller?

Merci