Exporter un graphique en pdf en conservant la mise en forme

Question

Bonjour,

J'essaie de créer une macro VBA qui exporte un graphique Excel en pdf. La spécificité de ma macro est que le pdf créé doit conserver la même taille que le graphique, donc sans marge. Pour y arriver, je copie le graphique dans Powerpoint, je redimensionne la présentation à la taille du graphique puis ensuite j'exporte depuis Powerpoint en pdf.

Le code que j'ai développé fonctionne presque, mais il ne conserve pas certains attributs de mise en forme. Par exemple, les étiquette que j'ai orienté en verticales sont remises à l&#8217;horizontale lors de l'exportation. 

Quelqu'un saurait-il comment corriger cela et exporter en conservant toute la mise en forme ?

Merci d'avance de votre aide !


Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub SaveAsPDF()

Dim objApp As Object
Dim lngResult As Long
Dim output As String

'Get paths for the output-file
output = Application.GetSaveAsFilename("Graph.pdf", "PDF files (*.pdf), *.pdf")
If output = "False" Then
Exit Sub
End If

'Check if file if locked
FileLocked:
If IsFileLocked(output) = True Then
answer = MsgBox("Unable to write to the specified file. File is use by another process." & Chr(13) & "Please close the application in question and try again.", vbExclamation + vbRetryCancel, "Permission denied")
If answer = vbRetry Then GoTo FileLocked
Exit Sub
End If

If ActiveChart Is Nothing Then
RangeSel = ActiveWindow.Selection.Address
A = Range(RangeSel).Height
B = Range(RangeSel).Width
Selection.Copy
c = 0
Else
'Read the geometry of graph
A = ActiveChart.Parent.Height
B = ActiveChart.Parent.Width
'copy chart into clipboard
ActiveChart.ChartArea.Select
Selection.Copy
c = 1
End If

'Is PowerPoint Running?
On Error Resume Next
Set objApp = GetObject(, "PowerPoint.Application")
If Not objApp Is Nothing Then
answer = MsgBox("PowerPoint is currently running and will be forcefully closed." & Chr(13) & "Any unsaved progress for the open presentation will be lost." & Chr(13) & Chr(13) & "Do you want to proceed?", vbYesNo + vbQuestion)
    If answer = vbNo Then
    Exit Sub
    End If
objApp.Quit
End If
On Error GoTo 0

'start PowerPoint
Set objApp = CreateObject("Powerpoint.Application")
With objApp
     .Presentations.Add
     .ActivePresentation.ApplyTemplate Filename:="J:\Modèles\System\Export.potx"
End With

'Adjust the slide-geometry
On Error GoTo ErrorHandler
With objApp
    .Presentations(1).Slides.Add 1, 1
    .Presentations(1).Slides(1).Shapes(1).Delete
    .Presentations(1).Slides(1).Shapes(1).Delete
    .Presentations(1).PageSetup.SlideHeight = A
    .Presentations(1).PageSetup.SlideWidth = B
End With

'Different paste methods are applied to graphs and tables
If c = 1 Then
objApp.Presentations(1).Slides(1).Shapes.Paste
Else
objApp.Presentations(1).Slides(1).Shapes.PasteSpecial (ppPasteEnhancedMetafile)
objApp.Presentations(1).Slides(1).Shapes(1).Height = A
objApp.Presentations(1).Slides(1).Shapes(1).Width = B
objApp.Presentations(1).Slides(1).Shapes(1).Left = 0
objApp.Presentations(1).Slides(1).Shapes(1).Top = 0
End If

'Save as PDF
objApp.Presentations(1).SaveAs Filename:=output, FileFormat:=ppSaveAsPDF

'Quit PPT
objApp.Quit

'Open PDF in default PDF Viewer
lngResult = ShellExecute(hwnd, "Open", output, "", "", vbNormalFocus)

'Release the objects
Set objApp = Nothing

On Error GoTo 0

Exit Sub

ErrorHandler:
If Err.Number = -2147467259 Then
Resume
Else
MsgBox "An error occured! Have fun figuring out what's wrong  :-P" & Chr(13) & "Maybe this errornumber will help you: " & Err.Number, vbMsgBoxSetForeground + vbExclamation, "ARRRRRRRRRRRRR"
objApp.Quit
End If

End Sub


Function IsFileLocked(sFile As String) As Boolean
    On Error Resume Next
     
     ' \ Open the file
    Open sFile For Binary Access Read Write Lock Read Write As #1
     ' \ Close the file
    Close #1
     
     ' \ If error occurs the document if open!
    If Err.Number <> 0 Then
         '\ Return true and clear error
        IsFileLocked = True
        Err.Clear
        On Error GoTo 0
    End If
End Function

NHenry · Answer

Bonjour, 

Quand vous postez un code, merci d'utiliser la coloration syntaxique (3ième icône en partant de la droite : ).

As-tu essayé de forcer les marges à 0 directement dans Excel ?

---------------------------------------------------------------------
[list=ordered][*]Pour poser correctement une question et optimiser vos chances d'obtenir des réponses, pensez à lire le règlement CS, celui-ci pour bien poser votre question ou encore celui-ci pour les PFE et autres exercices.[*]Quand vous postez un code, merci d'utiliser la coloration syntaxique (3ième icône en partant de la droite : ).[*]En VB.NET pensez à activer Option Explicit et Option Strict (propriété du projet) et à retirer l'import automatique de l'espace de nom Microsoft.VisualBasic (onglet Références dans les propriétés du projet).[*]Si votre problème est résolu (et uniquement si c'est le cas), pensez à mettre "Réponse acceptée" sur le ou les messages qui vous ont aidés/list
---

Exporter un graphique en pdf en conservant la mise en forme

1 réponse

Votre réponse

Discussions similaires