XL 2019 Macro qui enregistre en PDF à personnaliser

pat66

XLDnaute Impliqué
Bonsoir le forum,

J'ai besoin de votre expertise car j'ai une macro qui fonctionne très bien, mais je souhaiterai pouvoir faire 2 choses de plus, à savoir :
1- choisir le dossier d'enregistrement avec la boite de dialogue "enregistrer sous",
2 -si dans le répertoire choisit, le nom du PDF existe déjà soit il me propose de le remplacer soit de le renommer

merci beaucoup pour votre aide

Private Sub Print_PDF_Click()
Dim Mdp As String
Mdp = Application.InputBox("Veuillez introduire le mot de passe")
If Mdp <> "romi" Then MsgBox "Accès refusé !": Exit Sub
Application.ScreenUpdating = False
If Sheets("V3").Range("G27") = "" Then MsgBox "Vous devez renseigner la cellule !", vbCritical, "PL vous informe": Exit Sub
Dim Sh1 As Worksheet
Set Sh1 = Feuil24 'A adapter si besoin en fonction du codename de la feuille 1
With Sh1.PageSetup
.PrintArea = "A1:p48" 'Zone d'impression à adapter de la feuille 1
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
'Réglage des marges
.LeftMargin = Application.InchesToPoints(0.1) 'Marge gauche
.RightMargin = Application.InchesToPoints(0.1) 'Marge droite
.TopMargin = Application.InchesToPoints(1#) 'Marge haut de page
.BottomMargin = Application.InchesToPoints(0.1) 'Marge bas de page
.Orientation = xlLandscape 'Paysage
' .Orientation = xlPortrait 'Portrait
End With
Sheets(Array(Sh1.Name).Select

Dim NFichier As String
NFichier = Sh1.Range("G27") & "-" & Sh1.Range("F30") & "-" & Sh1.Range("F33") & Format(Date, "-dd-mm-yyyy")
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & NFichier, IgnorePrintAreas:=False, OpenAfterPublish:=False

Sh1.Select '<=== A rajouter
MsgBox "Le PDF a été enregistré." & vbCrLf & vbCrLf & "Ici ==> " & ThisWorkbook.Path & "-" & vbCrLf & vbCrLf & _
"Sous le nom : " & NFichier & ".pdf", 64, "PL vous informe..."
Set Sh1 = Nothing 'Decharge la feuille 1
'ActiveWindow.Close
Application.ScreenUpdating = True
End Sub

bonne soirée
 
Dernière édition:
Solution
Re,
VB:
Sub Print_PDF_Click()
Dim Mdp As String
Mdp = Application.InputBox("Veuillez introduire le mot de passe")
If Mdp <> "romi" Then MsgBox "Accès refusé !": Exit Sub
Application.ScreenUpdating = False
If Sheets("transmettre").Range("d6") = "" Then MsgBox "Vous devez renseigner la cellule !", vbCritical, "PL vous informe...": Exit Sub
Dim Sh1 As Worksheet
Set Sh1 = Feuil5 'A adapter si besoin en fonction du codename de la feuille 1
With Sh1.PageSetup
.PrintArea = "A1:p48" 'Zone d'impression à adapter de la feuille 1
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
'Réglage des marges
.LeftMargin = Application.InchesToPoints(0.1) 'Marge gauche
.RightMargin = Application.InchesToPoints(0.1) 'Marge droite
.TopMargin =...
Bonjour pat66, le forum
j'ai une macro qui fonctionne très bien
déjà, ce code ne peut pas fonctionner, ça part mal !
Sheets(Array(Sh1.Name).Select
un petit fichier exemple anonymisé ne serait pas de trop pour tester !
ou si tu peux mettre le code dans la fenêtre dédiée avec </> ce serait mieux pour la lecture.

Cordialement, @+
 
Dernière édition:

pat66

XLDnaute Impliqué
bonjour Yeahou, le forum

oui c'est vrai, j'ai voulu l'adapter mais il manquait une accolade à Sheets(Array(Sh1.name)).Select, a part ça, je viens de revérifier, ce code fonctionne

voici le classeur concerné avec la macro à modifier
1- choisir le dossier d'enregistrement avec la boite de dialogue "enregistrer sous",
2 -si dans le répertoire choisit pour enregistrer, le nom du PDF existe déjà soit il me propose de le remplacer soit de le renommer

Pour info, en commentaire sous la macro, il y a le code qui tout cela mais je n'arrive pas à l'adapter

Pat66
 

Pièces jointes

  • Classeur5.xlsm
    220.2 KB · Affichages: 19
Re,
VB:
Sub Print_PDF_Click()
Dim Mdp As String
Mdp = Application.InputBox("Veuillez introduire le mot de passe")
If Mdp <> "romi" Then MsgBox "Accès refusé !": Exit Sub
Application.ScreenUpdating = False
If Sheets("transmettre").Range("d6") = "" Then MsgBox "Vous devez renseigner la cellule !", vbCritical, "PL vous informe...": Exit Sub
Dim Sh1 As Worksheet
Set Sh1 = Feuil5 'A adapter si besoin en fonction du codename de la feuille 1
With Sh1.PageSetup
.PrintArea = "A1:p48" 'Zone d'impression à adapter de la feuille 1
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
'Réglage des marges
.LeftMargin = Application.InchesToPoints(0.1) 'Marge gauche
.RightMargin = Application.InchesToPoints(0.1) 'Marge droite
.TopMargin = Application.InchesToPoints(1#) 'Marge haut de page
.BottomMargin = Application.InchesToPoints(0.1) 'Marge bas de page
.Orientation = xlLandscape 'Paysage
' .Orientation = xlPortrait 'Portrait
End With
Sheets(Array(Sh1.name)).Select

Dim Nom_Fichier$, Titre_Box$, Test_Fichier As Byte
Titre_Box = "Export PDF"

Nom_Fichier = ThisWorkbook.Path & "\" & Sh1.Range("d6") & "-" & Sh1.Range("d7") & "-" & Sh1.Range("d9") & Format(Date, "-dd-mm-yyyy")
Do
    Test_Fichier = 0
    Nom_Fichier = Application.GetSaveAsFilename(Nom_Fichier, FileFilter:="Fichiers PDF (*.Pdf),*.Pdf", Title:=Titre_Box)
    If Not (Dir$(Nom_Fichier, vbNormal) = "") Then Test_Fichier = MsgBox(LCase(Nom_Fichier) & " existe déja" & vbLf & "en date du " & DateValue(FileDateTime(Nom_Fichier)) & vbLf & "voulez vous l'écraser ?", vbYesNo + vbQuestion, "Demande")
    If Test_Fichier = vbNo Then Titre_Box = "Redéfinissez le nom d'enregistrement"
    If Nom_Fichier = "Faux" Then MsgBox "Annulation, fichier non exporté !", vbOKOnly + vbInformation, "Information":        Exit Sub
Loop While Test_Fichier = vbNo
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Nom_Fichier, IgnorePrintAreas:=False, OpenAfterPublish:=False
Sh1.Select '<=== A rajouter
MsgBox "Le PDF a été enregistré." & vbCrLf & vbCrLf & "Ici ==> " & Nom_Fichier, 64, "PL vous informe..."

Set Sh1 = Nothing 'Decharge la feuille 1
'ActiveWindow.Close
Application.ScreenUpdating = True
End Sub
voila la macro !

Bien cordialement, @+
 
Dernière édition:

pat66

XLDnaute Impliqué
re,

merci
mais j'ai 2 lignes avec erreur:

Title:=Titre_Box)
et
Nom_Fichier = Application.GetSaveAsFilename(Nom_Fichier, FileFilter:="Fichiers PDF (*.Pdf),*.Pdf", If Not (Dir$(Nom_Fichier, vbNormal) = "") Then Test_Fichier = MsgBox(LCase(Nom_Fichier) & " existe déja" & vbLf & "en date du " & DateValue(FileDateTime(Nom_Fichier)) & vbLf & "voulez vous l'écraser ?", vbYesNo + vbQuestion, "Demande")

merci
 

pat66

XLDnaute Impliqué
Bonjour Yeahou,, le forum

je souhaiterai ajouter un bouton qui permet d'envoyer la même feuille par mail avec ou sans Outlook et puisque vous m'avez aidé à trouver la macro qui permet d'enregistrer en pdf, je me suis dis que peut être vous pourriez aussi m'aider à rédiger cette macro dans la mesure ou cela relève de vos compétences bien sur, ou peut être préférez vous que j'ouvre une nouvelle discussion ?

par avance je vous remercie

Pat66
 

Pièces jointes

  • Classeur6.xlsm
    217 KB · Affichages: 17

Discussions similaires