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]
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
[/CODE]