Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Office > PowerPoint

Reply
 
LinkBack Thread Tools Display Modes
  #16  
Old 01-17-2015, 02:29 AM
JohnWilson JohnWilson is offline Windows 7 64bit Office 2010 32bit
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,653
JohnWilson will become famous soon enough
Default


Sounds like you have the new loop inside the previous loop. Post you completed code and I'll have a look.
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
  #17  
Old 01-17-2015, 03:44 AM
JohnWilson JohnWilson is offline Windows 7 64bit Office 2010 32bit
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,653
JohnWilson will become famous soon enough
Default

See if this works:


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
'++++++++++++++++++++++++++++++NEW
If ActivePresentation.Slides.Count > 1 Then _
ActivePresentation.Slides(2).Shapes.Range.Copy
'++++++++++++++++++++++++++++++NEW
' 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.Slides.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

'=========================NEW
oSld.Shapes.Paste
'=========================NEW
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
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
  #18  
Old 01-17-2015, 12:00 PM
djlee djlee is offline Windows 8 Office 2010 64bit
Novice
 
Join Date: Jan 2015
Posts: 19
djlee is on a distinguished road
Default

This is fabulous! Thanks so much!

But the new slides still come in at the end, but after the current/selected slide.

DJ
Reply With Quote
  #19  
Old 01-17-2015, 12:11 PM
JohnWilson JohnWilson is offline Windows 7 64bit Office 2010 32bit
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,653
JohnWilson will become famous soon enough
Default

I didn't understand what you meant!

Try

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
Dim lngStart As Long
On Error GoTo err
'++++++++++++++++++++++++++++++NEW
If ActivePresentation.Slides.Count > 1 Then _
ActivePresentation.Slides(2).Shapes.Range.Copy
'++++++++++++++++++++++++++++++NEW
' Edit these to suit:
strPath = "c:\Users\John\Desktop\Pics\"
strFileSpec = "*.png"
SH = ActivePresentation.PageSetup.SlideHeight
SW = ActivePresentation.PageSetup.SlideWidth
strTemp = Dir(strPath & strFileSpec)
lngStart = ActiveWindow.Selection.SlideRange(1).SlideIndex
Do While strTemp <> ""
Set oSld = ActivePresentation.Slides.Add _
(lngStart + 1, ppLayoutBlank)
lngStart = lngStart + 1
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

'=========================NEW
oSld.Shapes.Paste
'=========================NEW
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
Exit Sub
err:
MsgBox "There's an error"
End Sub
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
  #20  
Old 01-17-2015, 12:35 PM
djlee djlee is offline Windows 8 Office 2010 64bit
Novice
 
Join Date: Jan 2015
Posts: 19
djlee is on a distinguished road
Default

You did it! Words can not express!

I recorded a macro to add a transition too all of the slides, but the recorded doesn't capture Select All. How do I make these commands apply a transition to all slides, please?

Code:
' Add Transition
    With ActiveWindow.Selection.SlideRange.SlideShowTransition
        .EntryEffect = ppEffectFadeSmoothly
        .Speed = ppTransitionSpeedFast
        .AdvanceOnClick = msoTrue
    End With
DJ
Reply With Quote
  #21  
Old 01-17-2015, 12:55 PM
JohnWilson JohnWilson is offline Windows 7 64bit Office 2010 32bit
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,653
JohnWilson will become famous soon enough
Default

Your code would workonly if all slides were already selected. To apply to all the slides in a presentation use:

' Add Transition
With ActivePresentation.Slides.Range.SlideShowTransitio n ' watch out for the auto added extra space!
.EntryEffect = ppEffectFadeSmoothly
.Speed = ppTransitionSpeedFast
.AdvanceOnClick = msoTrue
End With
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
  #22  
Old 01-17-2015, 02:00 PM
djlee djlee is offline Windows 8 Office 2010 64bit
Novice
 
Join Date: Jan 2015
Posts: 19
djlee is on a distinguished road
Default

It's perfect! Now I can get to work!

Thanks a bunch, John! I'm sending you a virtual Pepsi or beer or something! :-)

DJ
Reply With Quote
  #23  
Old 01-18-2015, 02:38 AM
JohnWilson JohnWilson is offline Windows 7 64bit Office 2010 32bit
Programmer
 
Join Date: Nov 2008
Location: UK
Posts: 1,653
JohnWilson will become famous soon enough
Default

Not Pepsi thank you!

If you are based in the UK, Seattle area, New Orleans or Vancouver then you might get a chance to buy a real beer!
__________________
Microsoft PowerPoint MVP
Free Advanced PowerPoint Tips and Tutorials
Reply With Quote
Reply

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
macro, data import from the ONLY text file in current folder ue418 Excel Programming 5 10-28-2017 12:52 PM
Import from .CUB files in MS Access vamsikrishnad Office 0 12-30-2014 03:19 AM
Import msg-files to Outlook Jeff10 Outlook 0 01-19-2013 10:56 AM
Import Multiple XML Files TallKewlOnez Excel Programming 1 04-09-2012 05:19 PM
How might I group a bunch of text boxes without getting a space around the edge? Augusta PowerPoint 0 08-25-2011 01:42 AM


All times are GMT -7. The time now is 10:11 PM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft