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’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 !

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
 
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