Try this then
Create two folders on the deskto 'PICIN' and 'Pics'
Put a couple of the presentations in PICIN and run this macro
Sub getImagesfromFolder()
Dim rayFileList() As String
Dim FolderPath As String
Dim FileSpec
Dim strTemp As String
Dim x As Long
FolderPath = Environ("USERPROFILE") & "\Desktop\PICIN\" ' Folder with presentations MUST end in \
FileSpec = "*.pp*"
ReDim rayFileList(1 To 1) As String
strTemp = Dir$(FolderPath & FileSpec)
While strTemp <> ""
rayFileList(UBound(rayFileList)) = FolderPath & strTemp
ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1)
strTemp = Dir
Wend
ReDim Preserve rayFileList(1 To UBound(rayFileList) - 1) 'kill top blank value
If UBound(rayFileList) > 1 Then
For x = 1 To UBound(rayFileList)
Call Exporter(rayFileList(x))
Next x
End If
End Sub
Sub Exporter(strMyFile As String)
Dim opic As Shape
Dim osld As Slide
Dim oPres As Presentation
Set oPres = Presentations.Open(strMyFile)
Set osld = oPres.Slides(1)
For Each opic In osld.Shapes
If opic.Type = msoPicture Then Exit For
If opic.Type = msoPlaceholder Then
If opic.PlaceholderFormat.ContainedType = msoPicture Then Exit For
End If
Next opic
' Make a folder called Pics on the desktop first
Call opic.Export(Environ("USERPROFILE") & "\Desktop\Pics\" & stripSuffix(oPres.Name) & ".jpg", _
ppShapeFormatJPG, oPres.PageSetup.SlideWidth, oPres.PageSetup.SlideHeight)
oPres.Saved = True
oPres.Close
End Sub
Function stripSuffix(strname As String) As String
Dim ipos As Integer
ipos = InStrRev(strname, ".")
stripSuffix = Left(strname, ipos - 1)
End Function
With any luck the images will end up in the Pics folder
|