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
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.
Pourriez-vous m'aider SVP. Je mets en PJ le fichier Excel
Merci d'avance!
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 SubLe 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 SubPourriez-vous m'aider SVP. Je mets en PJ le fichier Excel
Merci d'avance!
