Export PDF
a
Bonjour à tous,
J'ai une macro qui permet d'exporter une feuille Excel au format PDF.
La macro fonctionne plutôt bien après plusieurs tests.
J'aimerai optimiser cette macro et apporter des sécurités mais cela dépasse mes aptitudes.
Pouvez-vous m'éclairer sur ces différents points ?
- Lorsque la macro ouvre la fenêtre parcourir les dossiers, si je clique sur "Annuler", la macro s'exécute quand même et enregistre le PDF. Je n'ai pas de solutions pour ce petit inconvénient.
- Autre petit problème, si un fichier existe avec le même nom, la macro va écraser l'ancien par le nouveau. Et ça, c'est pas bon du tout.
- Un petit plus, serait d'enregistrer le dernier chemin utilisé pour enregistrer le fichier. C'est possible ça ?
voici le code :
Sub Exporter()
Dim msg As String
msg = MsgBox("Souhaitez-vous enregistrer cette feuille en PDF ?", vbQuestion + vbYesNo, "Exporter PDF")
If msg = vbNo Then
Exit Sub
End If
Dim cpt_i As Long
Dim ligne_depart As Long
Dim ligne_fin As Long
Dim Chemin As String
Dim x As Long
With Application.FileDialog(msoFileDialogFolderPicker)
'Définit un titre pour la boîte de dialogue
.Title = "Sélectionnez le répertoire dans lequel exporter"
'Affiche la boîte de dialogue
.Show
'Affiche le nom du dossier sélectionné
If .SelectedItems.Count > 0 Then
Chemin = .SelectedItems(1)
End If
End With
If Chemin = "" Then Chemin = ThisWorkbook.Path
Application.ScreenUpdating = False
ligne_depart = 11
ligne_fin = ligne_depart
'mise en page
With ThisWorkbook.Sheets("Export pdf").PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.05)
.FooterMargin = Application.InchesToPoints(0.05)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
'.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
ThisWorkbook.Sheets("Export pdf").PageSetup.PrintArea = ""
ThisWorkbook.Sheets("Export pdf").Range("A" & ligne_depart & ":F" & ThisWorkbook.Sheets("Export pdf").UsedRange.Rows.Count).Select
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ThisWorkbook.Sheets("Export pdf").PageSetup.PrintArea = "$A$1:$F$" & ThisWorkbook.Sheets("Export pdf").UsedRange.Rows.Count
ThisWorkbook.Sheets("Export pdf").ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & "\" & Format(Now, "yyyy mm dd ") & "- Material Order " & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End Sub
Merci par avance pour votre aide.
Bonne journée.
Bonjour,
si je clique sur "Annuler"
If .SelectedItems.Count > 0 Then
Chemin = .SelectedItems(1)
Else
MsgBox "aucun dossier sélectionné"
Exit Sub
End If
si un fichier existe avec le même nom
Txt = Dir(Chemin & "\" & Format(Now, "yyyy mm dd ") & "- Material Order " & ".pdf")
If Txt = "" Then
MsgBox "Le fichier n'existe pas"
Else
MsgBox "Le fichier " & Txt & " Existe"
End If
a
Bonjour SabV,
C'est super c'est exactement ça, il me manquait pas grand chose. Tout fonctionne très bien !!
Merci pour ce coup de pouce, je commençait à ramer la dessus.
Bonne soirée !