Exporting pictures from PPT to a folder and subfolders

Hello all,

I have a teaching presentation where screenshots are inserted in a number of slides (in the selection pane, the screenshots are named "Picture X" where the X is a number; the name being more or less randomly assigned by PPT when the image is pasted into the slide.) Only some slides show screenshots (some have a single image, some have multiple), others have no pictures at all.

What I'd need is a macro to go through each slide; when it encounters an element named "Picture X", it makes a copy of the element and saves it as a PNG into an "Images" folder on the desktop. The filename of the saved pic should be the slide number. In cases where there is more than one pic in a slide, it should save the topmost pic to "Images", then the pic underneath to a subfolder (i.e. Images\A), and the pic under that to a different subfolder (i.e. Images\B), and so on. Note I don't want it to copy the slide itself, only the specific picture elements.

To illustrate, let's say that this is the PPT selection pane for slide 5:

Text 1
Picture 12
Rectangle 1
Line 4
Picture 3
Picture 7

I'd need the topmost picture (in the example above: "Picture 12") to be saved as "5.PNG" (i.e. the slide number) to an "Images" folder created on the desktop.
Then the next image ("Picture 3") saved as "5.PNG" to Images\A.
Then the pic underneath that ("Picture 7") saved as "5.PNG" to Images\B, and so on.

When the macro ends, the "Images" folder would contain all the topmost pics from the entire presentation, the "A" subfolder would contain all the second-from-top images, the "B" subfoldfer all the 3rd-from-top images, and so on.

I don't know how to do this in VBA in PPT (I'm not even sure it's possible). Any help would be very warmly appreciated, and would save me hours of mind-bendingly dull manual work.

Thanks in advance for any help.

-Isa

This might need a bit of work from you but should get you started.

Code:

---

Sub exporter()
Dim opic As Shape
Dim L As Long
Dim x As Long
Dim osld As Slide
On Error Resume Next
For Each osld In ActivePresentation.Slides
For L = osld.Shapes.Count To 1 Step -1
If isPic(osld.Shapes(L)) Then
If x < 64 Then x = 64
Select Case x
Case 64
MkDir (Environ("USERPROFILE") & "\Desktop\Images\")
Call osld.Shapes(L).Export(Environ("USERPROFILE") & "\Desktop\Images\" & _
osld.SlideIndex & ".png", ppShapeFormatPNG)
x = x + 1
Case Else
MkDir (Environ("USERPROFILE") & "\Desktop\Images\" & UCase(Chr(x)) & "\")
Call osld.Shapes(L).Export(Environ("USERPROFILE") & "\Desktop\Images\" & UCase(Chr(x)) & _
"\" & osld.SlideIndex & ".png", ppShapeFormatPNG)
x = x + 1
End Select
End If
Next L
x = 0
Next osld
End Sub


Function isPic(osld As Slide)
Dim oshp As Shape
For Each oshp In osld.Shapes
If oshp.Type = msoPicture Then
isPic = True
Exit Function
End If
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.ContainedType = msoPicture Then
isPic = True
Exit Function
End If
End If
Next oshp
End Function

---