Convert embed charts in PPT to enhanced metafiles

[wolis]

Hi, I have a 70+ slide PPT presentation with embed charts from Excel that all need to be converted to pictures (so that data wouldn`t be accessible).

I have tried to compile a script that would loop through all slides, find all shapes, copy, delete and then paste them back. After that I`ll try to find a way for it to check if shapes are actually charts.

This is my first time trying to create a macro (I have no experience with VBA) so I guess there might be some silly mistakes.

So far I have got this:

[VBA]Sub ConvertCharts()
Dim SlideToCheck As Slide
Dim ShapeIndex As Integer
' Visit each slide
For Each SlideToCheck In ActivePresentation.Slides
' On each slide, count down through the shapes
For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1

' Copy, delete, Paste

SlideToCheck.Shapes(ShapeIndex).Copy
SlideToCheck.Shapes(ShapeIndex).Delete
Application.ActiveWindow.View.PasteSpecial DataType:=ppPasteEnhancedMetafile


Next
Next
End Sub[/VBA]

With this it shows an error at line "SlideToCheck.Shapes(ShapeIndex).Copy" , Shapes (unknown member) : Integer out of range. 0 is not the valid range of 1 to 0.

I`d be glad if someone could at least point me in the right direction.

[wolis]

I have now come up with this:
[VBA]Sub ConvertCharts()
Dim oShape As Shape
Dim oPresentation As Presentation
Dim oSlide As Slide
Dim oSelection As Selection
Dim l As Double
Dim t As Double

Set oPresentation = ActivePresentation
Set oSelection = Application.ActiveWindow.Selection

For Each oSlide In oPresentation.Slides
For Each oShape In oSlide.Shapes
oSlide.Select
oShape.Select
l = oShape.Left
t = oShape.Top

oShape.Copy
oShape.Delete

Application.ActiveWindow.View.PasteSpecial DataType:=ppPasteEnhancedMetafile

'Get the index of last insertion'
i = ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideNumber).Sh apes.Count
'Select the last inserted object'
ActiveWindow.Selection.SlideRange.Shapes(i).Select
With ActiveWindow.Selection.ShapeRange

.Left = l
.Top = t
End With

Next oShape
Next oSlide

' If Not oSelection Is Nothing Then
' oSelection.Select
' End If
End Sub[/VBA]

It seems to work, but it skips some of the charts ( For example 3 charts in a slide 2 are converted, 1 is not. In another almost identical slide 1 is converted 2 are not). Anyone know why?

[John Wilson]

I don't see how you would get that error but you would have to account for placeholders with charts which act in a special way (they create a blank copy when you delete them) as well as just charts.

See if this gets you going

[VBA]Sub ConvertCharts()
Dim SlideToCheck As Slide
Dim ShapeIndex As Long
Dim ThisShape As Shape
Dim myLeft As Single
Dim myTop As Single
' Visit each slide
For Each SlideToCheck In ActivePresentation.Slides
' On each slide, count down through the shapes
For ShapeIndex = SlideToCheck.Shapes.Count To 1 Step -1
Set ThisShape = SlideToCheck.Shapes(ShapeIndex)
'Is shape a placeholder
If ThisShape.Type = msoPlaceholder Then
If ThisShape.HasChart Then
ThisShape.Cut
SlideToCheck.Shapes(SlideToCheck.Shapes.Count).Select
ActiveWindow.View.PasteSpecial (ppPasteEnhancedMetafile)
End If
Else
If ThisShape.HasChart Then
myLeft = ThisShape.Left
myTop = ThisShape.Top
ThisShape.Cut
With SlideToCheck.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
.Left = myLeft
.Top = myTop
End With
End If
End If
Next
Next
End Sub[/VBA]

[wolis]

Yes, this did the trick! Thanks

[Cosmo]

This is the code I am using, if it is any help to you or if there's anything here that you might want to incorporate into your methods. I have stripped it down from a larger function to (hopefully) include only the code necessary to convert the charts. It should do what you want.

[vba]Public Function fixCharts()
Dim oSld As Slide
Dim i As Integer
Dim sngL As Single
Dim sngT As Single
Dim oshp As Shape
Dim oGroupItem As Shape

Dim oPres As Presentation
Dim fileName As String
Dim filePath As String
On Error GoTo errorCode
If Application.Presentations.Count = 0 Then
Exit Function
End If

Set oPres = ActivePresentation
For Each oSld In ActivePresentation.Slides
ActiveWindow.View.GotoSlide (oSld.SlideIndex)
For i = oSld.Shapes.Count To 1 Step -1
Set oshp = oSld.Shapes(i)
Call processShape(oSld, oshp)
Next i
Next oSld

Exit Function
errorCode:
Debug.Print "Error fixCharts function - " & Err.Description & " (" & Err.Number & ")"
Resume Next
End Function
Private Function replaceShape(oSld As Slide, oshp As Shape) As Boolean
Dim sngL As Single
Dim sngT As Single
Dim shpZorder As Long
On Error GoTo errorCode
sngL = oshp.Left
sngT = oshp.Top
shpZorder = oshp.ZOrderPosition
oshp.Cut
Debug.Print oshp.GroupItems.Count
With oSld.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
.Left = sngL
.Top = sngT
' Restore zOrder Position of original shape
While .ZOrderPosition > shpZorder
.ZOrder msoSendBackward
Wend
End With
Exit Function
errorCode:
Debug.Print "Error replaceShape function - " & Err.Description & " (" & Err.Number & ")"
Resume Next
End Function
Private Function processShape(oSld As Slide, oshp As Shape) As Shape
Dim sngL As Single
Dim sngT As Single
Dim oGroupItem As Shape
On Error GoTo errorCode
If oshp.Type = msoChart Then
Call replaceShape(oSld, oshp)
ElseIf oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.ContainedType = msoChart Then
sngL = oshp.Left
sngT = oshp.Top
oshp.Cut
oSld.Shapes(oSld.Shapes.Count).Select
DoEvents
ActiveWindow.View.PasteSpecial ppPasteEnhancedMetafile
End If
ElseIf oshp.Type = msoGroup Then
Dim x As Integer
Dim shpRng As ShapeRange
Dim groupCount As Integer
groupCount = oshp.GroupItems.Count
' Need to ungroup shapes (Otherwise, zOrder does not work properly!!)
If groupCount > 1 Then
Dim oGroupShps As ShapeRange
Set oGroupShps = oshp.Ungroup()
groupCount = oGroupShps.Count
For x = groupCount To 1 Step -1
Set oGroupItem = oGroupShps.Item(x)
If False Then
Set oGroupShps.Item(x) = processShape(oSld, oGroupItem)
Else
Call processShape(oSld, oGroupItem)
End If
Next x
Else
'Call processShape(oSld, oshp)
Set oshp = processShape(oSld, oshp)
End If
ElseIf oshp.Type = msoTextBox Then
'' This crashes on some textBoxes???
'Call replaceShape(oSld, oshp)
End If

Set processShape = oshp
Exit Function
errorCode:
Debug.Print "Error processShape function - " & Err.Description & " (" & Err.Number & ")"
Resume Next
End Function[/vba]