Need to import a bunch of .png files from a folder

[djlee]

I import a lot of .png files into PowerPoint. Currently, I create a Photo Album to get the pics in PowerPoint and then I copy those slides to my current presentation. Doing this manually has become quite inefficient and I need a easier way. I installed PowerPoint 2003 and tried to record the macro I need, but the recorder would not capture anything while the photo album dialog box was open. I was so bummed. :-(



So I'm looking for a macro to:

1. Insert *.png from a specified folder to the current slide
2. Tell me how many images were imported
3. Delete the .png files from the folder

Can somebody help me with this macro, please? I will be soooo grateful! :-)

DJ

[JohnWilson]

See if this does it:

Sub ImportABunch()
' based on code from pptfaq

Dim SW As Long
Dim SH As Long
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim iCount As Integer

' Edit these to suit:
strPath = "c:\Users\John\Desktop\Pics\"
strFileSpec = "*.png"
SH = ActivePresentation.PageSetup.SlideHeight
SW = ActivePresentation.PageSetup.SlideWidth
strTemp = Dir(strPath & strFileSpec)

Do While strTemp <> ""
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.S lides.Count + 1, ppLayoutBlank)
iCount = iCount + 1
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=msoTrue, _
Height:=msoTrue)

'reset height to a 150points less than slide height
With oPic
.LockAspectRatio = msoTrue
.Height = SH - 150
.Left = (SW - oPic.Width) / 2
.Top = 100
End With
' Get the next file that meets the spec and go round again
strTemp = Dir
Loop
If MsgBox("I added " & iCount & " Images." & vbCrLf & "Would you like to delete the files? This cannot be reversed.", vbYesNo) = vbYes Then
Kill strPath & "*png"""
End If
End Sub


based on code from here:
http://www.pptfaq.com/FAQ00352_Batch..._per_slide.htm

[djlee]

THANKS! I'm about to try it now. Before I do... do you know why this line is red?

Set oSld = ActivePresentation.Slides.Add(ActivePresentation.S lides.Count + 1, ppLayoutBlank)

DJ

[djlee]

It looks like you're resizing the images to 150 points less than slide height. Can I just comment out those lines? I don't need space for title boxes. I need the pics to fill the slides which they will do at their original size.

DJ

[JohnWilson]

Thjios website has inserted an extra space that wasn't in the original

In the line in red (error) S lides should be Slides

Try .height=SH and .Top=0 to make the slide full size

You could also say .Left=0 but the calcualtion should already give 0

When it works please go back to the other post and say it was solved. This stops people wasting time working on another solution.

[djlee]

This is working GREAT! I feel more efficient already!! :-)

I corrected the syntax error. There was a space in "slides".

Can you make the images import in order of creation time instead of by name?

DJ

[djlee]

I edited the resize commands. They're good!

I'm very happy. Just need to import by creation date. :-)

DJ

[JohnWilson]

Can be done but complicated and way beyond the scope here.

You would need to load the file paths into an array and sort it by date created using the file system object to read this value. Not simple at all.

[djlee]

Thanks for the heads up on the creation date thing!

I also use this pptfaq macro. http://www.pptfaq.com/FAQ00780_Copy_...esentation.htm

Can these lines be incorporated into your code?

Sub SuperDuper())

	Dim oSh as Shape
	Dim x as Long

	Set oSh=ActiveWindow.Selection.ShapeRange(1)
	oSh.Copy

	For x = 2 to ActivePresentation.Slides.Count
		ActivePresentation.Slides(x).Shapes.Paste
	Next

End Sub

The shape I want to copy is on slide 2. It's multiple shapes, actually and they are the only thing on slide 2. So I want to copy everything on slide 2 on top of each pic that was just imported.

Any chance I can get you to make this last change for me?

DJ

[djlee]

I resolved the date creation issue by changing the naming convention of the pics to include seconds. Yay!

DJ

[JohnWilson]

This is how to modify Steve's code. I'll leave you to incorporate it as a little exercise!

Sub SuperDuper()

Dim oSh As ShapeRange
Dim x As Long

Set oSh = ActivePresentation.Slides(2).Shapes.Range
oSh.Copy

For x = 3 To ActivePresentation.Slides.Count
ActivePresentation.Slides(x).Shapes.Paste
Next

End Sub

[djlee]

Cool beans!! I'll get right on it! :-)

DJ

[djlee]

I put my shapes on slide 2. I put the Dims up top with the other Dims. I put the rest under the reset lines.

I'm getting "type mismatch" on this
Set oSh = ActivePresentation.Slides(2).Shapes.Range

DJ

[JohnWilson]

Did you declare (DIM) osh as a SHAPERANGE? (Not a shape)

[djlee]

Oh, I don't know how I missed that. I thought I copied and pasted.

Fixed that line. No error now. But I am getting the shapes copied multiple times on each slide. I don't know how to make the copy and paste command apply only once to each new slide.

And I don't know how to make them insert at the current slide instead of the end.

I'm ready for my next exercise! :-)

DJ