I'm attempting to create an Excel macro which allows me to select any range with an Excel file and export that selection to PowerPoint while matching the size of a selected PowerPoint shape/object. Sometimes this data will be only data tables but sometimes it will be selection of charts and accompanying data tables (hence the decision to export as an Enhanced Meta File).
I've pasted my code below and the issue appears to be occurring at the "turn off aspect ratio" section, as I am able to get the linked meta file pasted into PowerPoint, but the aspect ratio lock remains on and the pasted item does not match the size/location of the selected item in PowerPoint.
Worth noting that I am relatively inexperienced with VBA but do have used it in the past.
Sub ExportToPPT()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPO As PowerPoint.ShapeRange
' Reference instance of PowerPoint
On Error Resume Next
' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
MsgBox "You need to have powerpoint open and an object selected to use this macro"
Exit Sub
End If
On Error GoTo 0
' Reference presentation and slide
On Error Resume Next
If PPApp.Windows.Count > 0 Then
' There is at least one presentation
' Use existing presentation
Set PPPres = PPApp.ActivePresentation
' Use active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Set PPO = PPPres.Slides(PPApp.ActiveWindow.Selection.ShapeRange(1))
x = PPApp.ActiveWindow.Selection.ShapeRange(1).Name
xx = PPApp.ActiveWindow.Selection.ShapeRange(1).Left
xy = PPApp.ActiveWindow.Selection.ShapeRange(1).Top
xh = PPApp.ActiveWindow.Selection.ShapeRange(1).Height
xw = PPApp.ActiveWindow.Selection.ShapeRange(1).Width
PPApp.ActiveWindow.Selection.ShapeRange(1).Delete
'Debug.Print x
End If
On Error GoTo 0
On Error GoTo Whoops
' Copy the range as a picture
Excel.Selection.Copy
Application.Wait (Now + TimeValue("00:00:02"))
' Paste the range
PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoTrue).Select
' Turn off aspect ratio
Dim oSh As PowerPoint.Shape
With PPApp.ActiveWindow.Selection
For Each oSh In .ShapeRange
oSh.LockAspectRatio = False
Next
End With
' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = xx
PPApp.ActiveWindow.Selection.ShapeRange.Top = xy
PPApp.ActiveWindow.Selection.ShapeRange.Height = xh
PPApp.ActiveWindow.Selection.ShapeRange.Width = xw
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
Exit Sub
Whoops:
MsgBox "An error occurred; the transfer was not successful. Please recheck your
selections in both PowerPoint and Excel and try again.", , "Error copying Excel Chart"
End Sub
This works for me:
Sub ExportToPPT()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation, ok As Boolean
Dim PPSlide As PowerPoint.Slide, ppObj As Object, ppObj2 As Object
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
ok = Not PPApp Is Nothing
If ok Then ok = PPApp.Windows.Count > 0
If Not ok Then
MsgBox "You need to have powerpoint open and an " & _
"object selected to use this macro"
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
Set ppObj = PPApp.ActiveWindow.Selection.ShapeRange(1)
Excel.Selection.Copy
Application.Wait (Now + TimeValue("00:00:02"))
Set ppObj2 = PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoTrue)(1)
With ppObj2
.LockAspectRatio = msoFalse
.Left = ppObj.Left
.Top = ppObj.Top
.Height = ppObj.Height
.Width = ppObj.Width
.ZOrder msoSendToBack
End With
ppObj.Delete 'remove the pre-selected placeholder
End Sub