XL 2013 Convertir classeur en PDF, crypter avec mot de passe et envoyer via Outlook

Saliou MBALO

XLDnaute Nouveau
Bonjour la famille,

je me fie à vous après plusieurs jours de recherches et essais pour finir un projet qui m'a été soumis et dont je n'arrive toujours pas à trouver la solution.

Objectif: L'objectif du projet est de convertir un classeur Excel en PDF, de le crypter avec un mot de passe et de l'envoyer via Outlook à une liste de destinataires.

Jusque là la conversion du classeur Excel en PDF et l'envoi via Outlook fonctionne avec du VBA.

Je mets ci-dessous le code fonctionnel

VB:
Option Explicit

Sub SendEmailTest()
SendEmailWithPDF (True)
End Sub

Sub SendEmailStores()
SendEmailWithPDF (False)
End Sub

Sub SendEmailWithPDF(bTest As Boolean)
Dim instructions As Worksheet
Dim menu As Worksheet
Dim parametrage As Worksheet
Dim base_de_donnees As Worksheet
Dim rngL As Range
Dim rngSN As Range
Dim rngTN As Range
Dim rngPath As Range
Dim c As Range
Dim nom_destinataire As Range
Dim mtr As Range
Dim lSend As Long
Dim lSent As Long
Dim lCount As Long
Dim lTest As Long
Dim lOff As Long
Dim Cellule As Range

Dim Source As String

Dim rngMtr As Range
Dim nomfeuille As String

Dim OutApp As Object
Dim OutMail As Object
Dim strSavePath As String
Dim strPathTest As String
Dim strPDFName As String
Dim strSendTo As String
Dim strSubj As String
Dim strBody As String
Dim strMsg As String
Dim strConf As String
Dim espace As String

On Error GoTo errHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strMsg = "Impossible de sélectionner les variables"
Set instructions = wksMenu
Set base_de_donnees = wksSet
Set menu = wksList
Set parametrage = WksRpt
Set rngL = menu.Range("StoreNums")
Set rngSN = parametrage.Range("rngSN")
Set rngTN = base_de_donnees.Range("rngTN")
Set rngPath = base_de_donnees.Range("rngPath")
Set rngMtr = WksRpt.Range("rngMtr")
Set nom_destinataire = WksRpt.Range("destinataire")

'test email address
strSendTo = base_de_donnees.Range("rngSendTo").Value
espace = " "

lCount = rngL.Cells.Count
'#columns offset for email address
lOff = 3

If bTest = True Then
   strConf = "Emails de Test: "
   lTest = rngTN.Value
   If lTest > 0 Then
      lCount = lTest
   End If
Else
   strConf = "Emails avec Pièce Jointe: "
End If

strConf = strConf & lCount _
      & " Emails seront envoyés"

If bTest = True Then
  If strSendTo = "" Then
    MsgBox "Veuillez entre un Email de Test!" _
     & vbCrLf _
     & "et réessayez!"
    GoSettings
    GoTo exitHandler
  Else
    strConf = strConf & vbCrLf _
      & "à " & strSendTo
  End If
End If

strConf = strConf & vbCrLf & vbCrLf
strConf = strConf & "Veuillez confirmer s'il vous plaît: " _
  & vbCrLf & _
  "Voulez vous envoyer les Emails?"

lSend = MsgBox(strConf, _
  vbQuestion + vbYesNo, "Emails envoyés")

If lSend = vbYes Then
  strSubj = base_de_donnees.Range("rngSubj").Value
  strBody = base_de_donnees.Range("rngBody").Value
  strSavePath = rngPath.Value

  strMsg = "Impossible d'utiliser Outlook!"
  On Error Resume Next
  Set OutApp = _
   GetObject(, "Outlook.Application")
  On Error GoTo errHandler

  If OutApp Is Nothing Then
      MsgBox "Outlook n'est pas ouvert. " _
       & vbCrLf _
       & "Ouvrez le et essayez à nouveau!"
      GoTo exitHandler
  End If

  strMsg = "Impossible de sélectionner le répertoire" _
     & " pour enregistrer les pièces jointes"
  If Right(strSavePath, 1) <> "\" Then
      strSavePath = strSavePath & "\"
  End If

  If DoesPathExist(strSavePath) Then

  Else
    MsgBox "Le dossier de sauvegarde, " _
      & strSavePath _
      & vbCrLf & "n'existe pas." _
      & vbCrLf & _
        "Les fichiers ne seront pas crées." _
      & vbCrLf & _
        "Veuillez séléctionner un dossier valide!."
      base_de_donnees.Activate
      rngPath.Activate
    GoTo exitHandler
  End If

  strMsg = "Impossible de commencer l'envoi des Emails"

   For Each c In rngL
     rngSN = c.Value

    If rngMtr.Value <> "" Then
        nomfeuille = rngMtr.Value
    End If

     strMsg = "Impossible de créer la pièce-jointe de " _
         & nom_destinataire.Value
     'strPDFName = "Test_" _
      '   & c.Value & ".pdf"
     strPDFName = rngMtr.Value & ".pdf"

    Dim EmailApp As Outlook.Application

    Set EmailApp = New Outlook.Application

     'Envoi de test mail
     If bTest = False Then
        strSendTo = c.Offset(0, lOff).Value
     End If

     'Conversion en PDF
      parametrage.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=strSavePath _
          & strPDFName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

     strMsg = "Impossible d'envoyer l'Email de " _
           & c.Value
      On Error Resume Next

      Dim EmailItem As Outlook.MailItem
    Set EmailItem = EmailApp.CreateItem(0)

      'With OutMail
          EmailItem.To = strSendTo
          EmailItem.CC = ""
          EmailItem.BCC = ""
          EmailItem.Subject = strSubj
          EmailItem.Body = strBody
          EmailItem.Attachments.Add _
             strSavePath & strPDFName
          EmailItem.Send
      'End With
      On Error GoTo 0
     lSent = lSent + 1
     If lSent >= lCount Then Exit For
  Next c

  Application.ScreenUpdating = True
  instructions.Activate

  MsgBox "Les Emails ont bien été envoyés!"

End If

exitHandler:
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   Set OutMail = Nothing
   Set OutApp = Nothing

   Set instructions = Nothing
   Set base_de_donnees = Nothing
   Set menu = Nothing
   Set parametrage = Nothing
   Set rngL = Nothing
   Set rngSN = Nothing
   Set rngPath = Nothing

   Exit Sub

errHandler:
   MsgBox strMsg
   Resume exitHandler

End Sub

Function DoesPathExist _
  (myPath As String) As Boolean
  Dim TestStr As String
  If Right(myPath, 1) <> "\" Then
      myPath = myPath & "\"
  End If
  TestStr = ""
  On Error Resume Next
  TestStr = Dir(myPath & "nul")
  On Error GoTo 0

  DoesPathExist = CBool(TestStr <> "")

End Function

Sub GetFolderFilesPDF()
Dim rngPath As Range
Dim PathStart As String
On Error Resume Next

Set rngPath = wksSet.Range("rngPath")
PathStart = ActiveWorkbook.Path

With Application.FileDialog _
 (msoFileDialogFolderPicker)
   .AllowMultiSelect = False
   .InitialFileName = PathStart
   .Show

   If .SelectedItems.Count > 0 Then
       rngPath.Value = _
         .SelectedItems(1)
   End If

End With

End Sub



Le souci est que je n'arrive pas à crypter le fichier avec un mot de passe.

L'exécution du script me signale une erreur au niveau de l'entrée de la fonction de conversion du PDF

""Impossible de créer la pièce-jointe de.... "

j'ai trouver un script qui permet la conversion et le cryptage d'un PDF avec mot de passe mais je n'arrive pas à l'adapter à mon code.

VB:
Option Explicit

Sub Mail()
Dim Destinataire As String
Dim sNomPdf As String
Dim sDossier As String
Dim sNomCrypt As String
Dim objApp As Object
Dim File As Object
Dim OutApp As Object
Dim objMessage As Object

Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application

    sDossier = ThisWorkbook.Path

    Destinataire = "monmail@outlook.com"
    sNomPdf = sDossier & "\" & "Test.pdf"

    Feuil1.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNomPdf, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False

    sNomCrypt = sDossier & "\" & "Tempo.pdf"
    EncryptPDFUsingPdfforgeDll sNomPdf, sNomCrypt

    Kill sNomPdf
    Name sNomCrypt As sNomPdf

    Dim EmailItem As Outlook.MailItem
    Set EmailItem = EmailApp.CreateItem(0)

    EmailItem.To = Destinataire
    EmailItem.CC = ""
    EmailItem.BCC = ""
    EmailItem.Subject = "Test"
    EmailItem.HTMLBody = "Bonjour," & vbNewLine & vbNewLine & "Veuillez trouvez ci-joint votre Document. Votre mot de passe est ." & _
    vbNewLine & vbNewLine & _
    "Cordialement!," & vbNewLine & _
    "Contact"
    Source = ThisWorkbook.FullName
    EmailItem.Attachments.Add ("C:\Users\bc00T349\Desktop\Test.pdf")
    EmailItem.Send

    Set objApp = Nothing

    Set objMessage = Nothing
End Sub

Private Sub EncryptPDFUsingPdfforgeDll(sNomFichier As String, sOutputCrypt As String)
Dim Pdf As Object, Crypt As Object

    Set Crypt = CreateObject("pdfforge.pdf.PDFEncryptor")

    With Crypt
        .AllowAssembly = False
        .AllowCopy = False
        .AllowFillIn = False
        .AllowModifyAnnotations = False
        .AllowModifyContents = False
        .AllowPrinting = True
        .AllowPrintingHighResolution = True
        .AllowScreenReaders = False
        .EncryptionMethod = 2

        .OwnerPassword = "master"
        .UserPassword = "master"
    End With

    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.EncryptPDFFile sNomFichier, sOutputCrypt, Crypt
    Set Pdf = Nothing

    Set Crypt = Nothing
End Sub


Pourriez-vous m'aider SVP. Je mets en PJ le fichier Excel

Merci d'avance!
 

Pièces jointes

  • test-mail.xlsm
    101.8 KB · Affichages: 28

Saliou MBALO

XLDnaute Nouveau
Salut, voir par ici ? et l'adapter à ton contexte.

Bonjour Kiki29,
Merci pour cette solution.
Maintenant serait-il possible de fusionner les deux macros pour en faire une seule.
Je vous mets le code ci-dessous:
VB:
Option Explicit

Sub Mail()
Dim Destinataire As String
Dim sNomPdf As String
Dim sDossier As String
Dim sNomCrypt As String
Dim objApp As Object
Dim File As Object
Dim OutApp As Object
Dim objMessage As Object

Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application

    sDossier = ThisWorkbook.Path

    Destinataire = "monmail@outlook.com"
    sNomPdf = sDossier & "\" & "Test.pdf"

    Feuil1.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sNomPdf, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=False

    sNomCrypt = sDossier & "\" & "Tempo.pdf"
    EncryptPDFUsingPdfforgeDll sNomPdf, sNomCrypt

    Kill sNomPdf
    Name sNomCrypt As sNomPdf

    Dim EmailItem As Outlook.MailItem
    Set EmailItem = EmailApp.CreateItem(0)

    EmailItem.To = Destinataire
    EmailItem.CC = ""
    EmailItem.BCC = ""
    EmailItem.Subject = "Test"
    EmailItem.HTMLBody = "Bonjour," & vbNewLine & vbNewLine & "Veuillez trouvez ci-joint votre Document. Votre mot de passe est ." & _
    vbNewLine & vbNewLine & _
    "Cordialement!," & vbNewLine & _
    "Contact"
    Source = ThisWorkbook.FullName
    EmailItem.Attachments.Add ("C:\Users\bc00T349\Desktop\Test.pdf")
    EmailItem.Send

    Set objApp = Nothing

    Set objMessage = Nothing
End Sub

Private Sub EncryptPDFUsingPdfforgeDll(sNomFichier As String, sOutputCrypt As String)
Dim Pdf As Object, Crypt As Object

    Set Crypt = CreateObject("pdfforge.pdf.PDFEncryptor")

    With Crypt
        .AllowAssembly = False
        .AllowCopy = False
        .AllowFillIn = False
        .AllowModifyAnnotations = False
        .AllowModifyContents = False
        .AllowPrinting = True
        .AllowPrintingHighResolution = True
        .AllowScreenReaders = False
        .EncryptionMethod = 2

        .OwnerPassword = "master"
        .UserPassword = "master"
    End With

    Set Pdf = CreateObject("pdfforge.pdf.pdf")
    Pdf.EncryptPDFFile sNomFichier, sOutputCrypt, Crypt
    Set Pdf = Nothing

    Set Crypt = Nothing
End Sub

Merci d'avance
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T