XL 2019 Macro qui enregistre en PDF à personnaliser

[pat66]

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 = "A148" '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

 

[Bernard_XLD]

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, @+

 

[pat66]

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

 

[pat66]

re,

je crois que j'ai réussi avec un peu de patience, cela fonctionne bien

en tout cas, merci

Pat66

 

[Bernard_XLD]

Re,

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, @+

 

[pat66]

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

 

[Bernard_XLD]

un glisser de souris involontaire et malheureux, j'ai remis à jour le code du post 5

 

[pat66]

re,

un grand merci pour ton aide

c'est impeccable

bon we

Pat

 

[pat66]

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

 

[Bernard_XLD]

Bonjour

C'est un autre problème alors ouvres un nouveau fil !

Bien cordialement, @+

 

[pat66]

re,

ok merci

a plouch