I have linked macro-enabled worksheet objects from excel to 25 different powerpoint slides in my powerpoint deck. Some slides have up to three linked objects and others have only one. For the slides that have multiple linked objects, I need the jpg output to contain all three objects / images. The VBA script that I am using sometimes works for every slide, sometimes works on 10 slides, 15 slides, or none. I need to be able to make the vba code bulletproof so that this can be reliable moving forward.
I expect this VBA code to have the same result time and time again... but when I run it constantly (5 times) I receive different results. Shape (unknown member) Object does not exist. When I receive this error, I look at my powerpoint deck and see that a blank slide has been created but obviously the code has failed. Here is a list of all of my objects when I open the immediate window: Below this list is my script which provided inconsistent result.
Slide 1: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 2: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 2: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 2: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 3: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 4: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 5: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 6: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 6: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 6: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 7: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 8: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 9: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 10: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 10: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 10: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 11: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 12: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 13: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 14: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 14: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 14: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 15: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 16: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 17: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 18: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 18: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 18: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 19: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 20: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 21: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 22: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 22: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 22: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 23: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 24: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 25: Linked OLE Object - Excel.SheetMacroEnabled.12
Current Script:
Sub CaptureAndSaveAllOLEObjectsAsHighResJPG()
Dim slide As slide
Dim shape As shape
Dim pic As shape
Dim picPath As String
Dim picName As String
Dim slideIndex As Integer
Dim scaleFactor As Double
Dim originalWidth As Single
Dim originalHeight As Single
Dim saveFolder As String
Dim positionX As Single ' Position tracking variable for spacing
' Define the folder to save the screenshots
saveFolder = "C:\Users\KWP863\Desktop\Testing\" ' Change this
to your desired path
' Create the folder if it doesn't exist
If Dir(saveFolder, vbDirectory) = "" Then
MkDir saveFolder
Debug.Print "Created folder: " & saveFolder
End If
' Set the scaling factor to increase resolution
scaleFactor = 3# ' Increase this factor for higher resolution
' Loop through each slide in the presentation
For Each slide In ActivePresentation.Slides
slideIndex = slide.slideIndex
' Create a blank slide to combine all pictures
Dim combinedSlide As slide
Set combinedSlide =
ActivePresentation.Slides.Add(ActivePresentation.Slides.Count +
1, ppLayoutBlank)
' Reset position tracking variable
positionX = 0
' Loop through each shape in the slide
For Each shape In slide.Shapes
' Check if the shape is a linked or embedded OLE object
If shape.Type = msoLinkedOLEObject Or shape.Type =
msoEmbeddedOLEObject Then
' Copy the OLE object
shape.Copy
' Paste the OLE object as a picture (Enhanced Metafile)
On Error Resume Next
Set pic =
combinedSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)(1)
On Error GoTo 0
If Not pic Is Nothing Then
' Store the original dimensions
originalWidth = pic.Width
originalHeight = pic.Height
' Scale the picture up
pic.Width = originalWidth * scaleFactor
pic.Height = originalHeight * scaleFactor
' Position the picture on the combined slide
pic.Left = positionX
pic.Top = 0 ' Fixed top position for all pictures
' Update position for the next picture (add the
original width for spacing)
positionX = positionX + (originalWidth *
scaleFactor) + 10 ' Adding 10 for spacing between
objects
Else
Debug.Print "Error: Could not paste shape on Slide
" & slideIndex
End If
End If
Next shape
' Save the combined picture as a high-resolution JPG file
picName = "Slide" & slideIndex & "_OLEObjects.jpg"
picPath = saveFolder & picName
' Debug print statements to check paths
Debug.Print "Saving to: " & picPath
' Export the combined slide as a picture
combinedSlide.Shapes.Range.Export picPath, ppShapeFormatJPG
' Delete the combined slide
combinedSlide.Delete
Next slide
MsgBox "High-resolution screenshots taken and saved for all
linked objects.", vbInformation
End Sub
I have linked macro-enabled worksheet objects from excel to 25 different powerpoint slides in my powerpoint deck. Some slides have up to three linked objects and others have only one. For the slides that have multiple linked objects, I need the jpg output to contain all three objects / images. The VBA script that I am using sometimes works for every slide, sometimes works on 10 slides, 15 slides, or none. I need to be able to make the vba code bulletproof so that this can be reliable moving forward.
I expect this VBA code to have the same result time and time again... but when I run it constantly (5 times) I receive different results. Shape (unknown member) Object does not exist. When I receive this error, I look at my powerpoint deck and see that a blank slide has been created but obviously the code has failed. Here is a list of all of my objects when I open the immediate window: Below this list is my script which provided inconsistent result.
Slide 1: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 2: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 2: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 2: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 3: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 4: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 5: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 6: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 6: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 6: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 7: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 8: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 9: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 10: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 10: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 10: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 11: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 12: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 13: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 14: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 14: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 14: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 15: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 16: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 17: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 18: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 18: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 18: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 19: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 20: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 21: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 22: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 22: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 22: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 23: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 24: Linked OLE Object - Excel.SheetMacroEnabled.12
Slide 25: Linked OLE Object - Excel.SheetMacroEnabled.12
Current Script:
Sub CaptureAndSaveAllOLEObjectsAsHighResJPG()
Dim slide As slide
Dim shape As shape
Dim pic As shape
Dim picPath As String
Dim picName As String
Dim slideIndex As Integer
Dim scaleFactor As Double
Dim originalWidth As Single
Dim originalHeight As Single
Dim saveFolder As String
Dim positionX As Single ' Position tracking variable for spacing
' Define the folder to save the screenshots
saveFolder = "C:\Users\KWP863\Desktop\Testing\" ' Change this
to your desired path
' Create the folder if it doesn't exist
If Dir(saveFolder, vbDirectory) = "" Then
MkDir saveFolder
Debug.Print "Created folder: " & saveFolder
End If
' Set the scaling factor to increase resolution
scaleFactor = 3# ' Increase this factor for higher resolution
' Loop through each slide in the presentation
For Each slide In ActivePresentation.Slides
slideIndex = slide.slideIndex
' Create a blank slide to combine all pictures
Dim combinedSlide As slide
Set combinedSlide =
ActivePresentation.Slides.Add(ActivePresentation.Slides.Count +
1, ppLayoutBlank)
' Reset position tracking variable
positionX = 0
' Loop through each shape in the slide
For Each shape In slide.Shapes
' Check if the shape is a linked or embedded OLE object
If shape.Type = msoLinkedOLEObject Or shape.Type =
msoEmbeddedOLEObject Then
' Copy the OLE object
shape.Copy
' Paste the OLE object as a picture (Enhanced Metafile)
On Error Resume Next
Set pic =
combinedSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)(1)
On Error GoTo 0
If Not pic Is Nothing Then
' Store the original dimensions
originalWidth = pic.Width
originalHeight = pic.Height
' Scale the picture up
pic.Width = originalWidth * scaleFactor
pic.Height = originalHeight * scaleFactor
' Position the picture on the combined slide
pic.Left = positionX
pic.Top = 0 ' Fixed top position for all pictures
' Update position for the next picture (add the
original width for spacing)
positionX = positionX + (originalWidth *
scaleFactor) + 10 ' Adding 10 for spacing between
objects
Else
Debug.Print "Error: Could not paste shape on Slide
" & slideIndex
End If
End If
Next shape
' Save the combined picture as a high-resolution JPG file
picName = "Slide" & slideIndex & "_OLEObjects.jpg"
picPath = saveFolder & picName
' Debug print statements to check paths
Debug.Print "Saving to: " & picPath
' Export the combined slide as a picture
combinedSlide.Shapes.Range.Export picPath, ppShapeFormatJPG
' Delete the combined slide
combinedSlide.Delete
Next slide
MsgBox "High-resolution screenshots taken and saved for all
linked objects.", vbInformation
End Sub
1 Answer
Reset to default 0Following from comments above:
Sub CaptureAndSaveAllOLEObjectsAsHighResJPG()
'use Const for fixed values
Const SAVE_FOLDER As String = "C:\Temp\PPT_test\" ' Change this to your desired path
Const SCALE_FACTOR As Long = 3 ' Increase this factor for higher resolution
'### avoid using a type name like "slide", "shape" as a variable name...
Dim sld As Slide, pres As Presentation, combinedSlide As Slide
Dim shp As Shape, pic As Shape
Dim picPath As String, picName As String
Dim slideIndex As Integer
Dim originalWidth As Single, originalHeight As Single
Dim positionX As Single ' Position tracking variable for spacing
If Dir(SAVE_FOLDER, vbDirectory) = "" Then ' Create the folder if it doesn't exist
MkDir SAVE_FOLDER
Debug.Print "Created folder: " & SAVE_FOLDER
End If
Set pres = ActivePresentation
For Each sld In pres.Slides
slideIndex = sld.slideIndex
' Create a blank slide to combine all pictures
Set combinedSlide = pres.Slides.Add(pres.Slides.Count + 1, ppLayoutBlank)
' Reset position tracking variable
positionX = 0
' Loop through each shape in the slide
For Each shp In sld.Shapes
' Check if the shape is a linked or embedded OLE object
If shp.Type = msoLinkedOLEObject Or shp.Type = msoEmbeddedOLEObject Then
shp.Copy ' Copy the OLE object
DoEvents
Set pic = PastePicRetry(combinedSlide) 'retries if needed
If Not pic Is Nothing Then
originalWidth = pic.Width ' Store the original dimensions
originalHeight = pic.Height
pic.Width = originalWidth * SCALE_FACTOR ' Scale the picture up
pic.Height = originalHeight * SCALE_FACTOR
pic.Left = positionX ' Position the picture on the combined slide
pic.Top = 0 ' Fixed top position for all pictures
' Update position for the next picture (add the original width for spacing)
positionX = positionX + (originalWidth * SCALE_FACTOR) + 10 ' Adding 10 for spacing between objects
End If
End If
Next shp
picName = "Slide" & slideIndex & "_OLEObjects.jpg"
picPath = SAVE_FOLDER & picName
Debug.Print "Saving to: " & picPath ' Debug print statements to check paths
combinedSlide.Shapes.Range.Export picPath, ppShapeFormatPNG ' Export the combined slide as a picture
combinedSlide.Delete
Next sld
MsgBox "High-resolution screenshots taken and saved for all linked objects.", vbInformation
End Sub
'Try to paste on slide `sld` - retry up to 20 times
' Return the pasted shape if paste succeeds
Function PastePicRetry(sld As Slide) As Shape
Dim i As Long, pic As Shape
Do While i < 20
On Error Resume Next
Set pic = sld.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)(1)
On Error GoTo 0
If pic Is Nothing Then
Debug.Print "### Paste #" & i & " failed for slide# " & sld.slideIndex
DoEvents
i = i + 1
Else
Debug.Print "Paste #" & i & " succeeded for slide# " & sld.slideIndex
Set PastePicRetry = pic
Exit Function
End If
Loop
End Function
pic = Nothing, or it may just retain the value from a previous paste... This seems like a similar problem to other post here about problems pasting content - often just trying the paste again solves the problem: you can wrap that up in a separate sub and only get a warning if paste has still failed after (eg) 5 tries. Eg see stackoverflow.com/a/79245517/478884 - that could be adapted for PPT – Tim Williams Commented Feb 7 at 18:10