Load BMP/JPG images to PPT slides

User avatar
ChrisGreaves
PlutoniumLounger
Posts: 15498
Joined: 24 Jan 2010, 23:23
Location: brings.slot.perky

Load BMP/JPG images to PPT slides

Post by ChrisGreaves »

Not my finest work. I needed a "quickie" to load a family of images, one per slide, into a presentation I'm giving on the Goldfields Water Supply.

Code: Select all

Sub FolderToSlideShow()
    Dim pres As Presentation
    Set pres = ActivePresentation
    ''' Remove any existing slides
    While pres.Slides.Count > 0
        pres.Slides(1).Delete
    Wend
    Dim strFolder As String
    ''' Folder assumed same as presentation
    strFolder = pres.Path & "\"
    Dim strImage As String
    strImage = Dir(strFolder)
    While Len(strImage) > 0
        ''' BitMaps or Jpeg files only
        If (UCase(Right(strImage, 4)) = ".BMP") Or (UCase(Right(strImage, 4)) = ".JPG") Then
            Dim sld As Slide
            Set sld = pres.Slides.Add(pres.Slides.Count + 1, ppLayoutBlank)
            sld.Select
            On Error Resume Next
            ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strFolder & strImage, _
                                LinkToFile:=msoFalse, _
                                SaveWithDocument:=msoTrue, _
                                Left:=10, _
                                Top:=10).Select
        Else
        End If
        strImage = Dir ' Get next file
    Wend
    ''' Set timings to ONE SECOND interval
    With ActivePresentation.Slides.Range.SlideShowTransition
        .EntryEffect = ppEffectNone
        .AdvanceOnClick = msoFalse
        .AdvanceOnTime = msoTrue
        .AdvanceTime = 1
        .SoundEffect.Type = ppSoundNone
    End With
End Sub
An expensive day out: Wallet and Grimace

User avatar
Rudi
gamma jay
Posts: 25455
Joined: 17 Mar 2010, 17:33
Location: Cape Town

Re: Load BMP/JPG images to PPT slides

Post by Rudi »

Thanks Chris...

Any code is fine work, no matter what it's programmed to do. I always say... "You must not work for the computer, you must get the computer to work for you!"

So in saying that, let me promote my XLS code to add to Chris's PPT code:

See this post to get some code to add category %'s to an Excel histogram table.
Regards,
Rudi

If your absence does not affect them, your presence didn't matter.

User avatar
ChrisGreaves
PlutoniumLounger
Posts: 15498
Joined: 24 Jan 2010, 23:23
Location: brings.slot.perky

Re: Load BMP/JPG images to PPT slides

Post by ChrisGreaves »

Rudi wrote:I always say... "You must not work for the computer, you must get the computer to work for you!"
Seriously. This rattled me.
I've spent the last week convincing people that they should be in control of the computer, not the other way around!
Rudi, Your comment was most timely (and gives me a warm glow!)
An expensive day out: Wallet and Grimace

User avatar
Rudi
gamma jay
Posts: 25455
Joined: 17 Mar 2010, 17:33
Location: Cape Town

Re: Load BMP/JPG images to PPT slides

Post by Rudi »

Rudi, Your comment was most timely (and gives me a warm glow!) :grin:

Tx Chris...now I have a warm glow!
Regards,
Rudi

If your absence does not affect them, your presence didn't matter.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Load BMP/JPG images to PPT slides

Post by HansV »

Be careful you two don't set the Lounge afire! :grin:
Best wishes,
Hans

User avatar
ChrisGreaves
PlutoniumLounger
Posts: 15498
Joined: 24 Jan 2010, 23:23
Location: brings.slot.perky

Re: Load BMP/JPG images to PPT slides

Post by ChrisGreaves »

HansV wrote:Be careful you two don't set the Lounge afire!
Heh heh.
Over the past few hours I've felt a tad guilty.
As a "host" (whatever that is) I feel I ought to have been sifting through these un-responded messages.
I know that some posts are not necessarily expecting a response - some of my FYI posts are like that - but all the same, starting a thread and receiving not even a "thank you" from one of us regulars is rather like walking into a store and not being acknowledged by the sales staff.
Hence my determination to TRY and respond to the "stalest" unresponded message each day; unless someone else beats me to it .....
An expensive day out: Wallet and Grimace

User avatar
StuartR
Administrator
Posts: 12577
Joined: 16 Jan 2010, 15:49
Location: London, Europe

Re: Load BMP/JPG images to PPT slides

Post by StuartR »

That sounds like a very neighbourly kind of thing to do.

Thank you.
StuartR


User avatar
ChrisGreaves
PlutoniumLounger
Posts: 15498
Joined: 24 Jan 2010, 23:23
Location: brings.slot.perky

Re: Load BMP/JPG images to PPT slides

Post by ChrisGreaves »

StuartR wrote:That sounds like a very neighbourly kind of thing to do.
Well, since I removed Hans and Skitterbug as my Friends, I don't seem to have any friends left .... (sniff!) :grin:
An expensive day out: Wallet and Grimace

BigKev
StarLounger
Posts: 78
Joined: 10 Feb 2010, 12:54
Location: Jeddah, Saudi Arabia

Re: Load BMP/JPG images to PPT slides

Post by BigKev »

I have several programs written in .NET to create Excel Workbooks from Database data and then add the worksheets to PowerPoint Presentations. I have taken the liberty to add some code to Chris's to center the image after it's been added. This process is easy as you can see. The harder part is resizing the image or object once it's been added as in many cases the image/object turns out to be larger than the slide. I have had many attempts at doing this in a generic fashion but none have been totally successful due to the maintenance of the aspect ratio .

Any help on this will be greatly appreciated and Chris, if you need a friend you can always count on me.

Code: Select all

Sub FolderToSlideShow()
    Dim pres As Presentation
    Set pres = ActivePresentation
    ''' Remove any existing slides
    While pres.Slides.Count > 0
        pres.Slides(1).Delete
    Wend
    Dim strFolder As String
    
    strFolder = "K:\Wallpaper\"                     ' My wallpaper folder
    Dim strImage As String
    strImage = Dir(strFolder)
    Dim FoundImage As Boolean
    While Len(strImage) > 0
        ''' BitMaps or Jpeg files only
        If (UCase(Right(strImage, 4)) = ".BMP") Or (UCase(Right(strImage, 4)) = ".JPG") Then
            FoundImage = True
            Dim sld As Slide
            Set sld = pres.Slides.Add(pres.Slides.Count + 1, ppLayoutBlank)
            sld.Select
            On Error Resume Next
            Dim shp As Shape
            ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strFolder & strImage, _
                                LinkToFile:=msoFalse, _
                                SaveWithDocument:=msoTrue, _
                                Left:=10, _
                                Top:=10).Select
            
            sh = pres.PageSetup.SlideHeight

            Dim sw As Single
    
            sw = pres.PageSetup.SlideWidth
    
            Dim oh As Single
               
            oh = sld.Shapes(1).Height
    
            Dim ow As Single
    
            ow = sld.Shapes(1).Width
    
            oh = sld.Shapes(1).Height
            ow = sld.Shapes(1).Width
    
            ' Center the shape
            sld.Shapes(1).Left = (sw - ow) / 2
            sld.Shapes(1).Top = (sh - oh) / 2
        Else
        End If
        
        strImage = Dir ' Get next file
    Wend
    ''' Set timings to ONE SECOND interval
    If FoundImage Then
        With ActivePresentation.Slides.Range.SlideShowTransition
            .EntryEffect = ppEffectNone
            .AdvanceOnClick = msoFalse
            .AdvanceOnTime = msoTrue
            .AdvanceTime = 1
            .SoundEffect.Type = ppSoundNone
        End With
    End If
    
End Sub
Cheers,
Kevin Bell
Last edited by HansV on 03 Apr 2010, 10:28, edited 1 time in total.
Reason: to add [code]...[/code] tags around macro.

User avatar
HansV
Administrator
Posts: 78235
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Load BMP/JPG images to PPT slides

Post by HansV »

Here is a version that resizes the images:

Code: Select all

Sub FolderToSlideShow()
  Dim pres As Presentation
  Set pres = ActivePresentation
  Dim strFolder As String
  Dim strImage As String
  Dim FoundImage As Boolean
  Dim sld As Slide
  Dim shp As Shape
  Dim sh As Single
  Dim sw As Single
  Dim oh As Single
  Dim ow As Single

  ' Remove any existing slides
  Do While pres.Slides.Count > 0
    pres.Slides(1).Delete
  Loop

  strFolder = "K:\Wallpaper\" ' My wallpaper folder
  strImage = Dir(strFolder)
  Do While Len(strImage) > 0
    ' BitMaps or Jpeg files only
    If (UCase(Right(strImage, 4)) = ".BMP") Or (UCase(Right(strImage, 4)) = ".JPG") Then
      FoundImage = True
      Set sld = pres.Slides.Add(pres.Slides.Count + 1, ppLayoutBlank)
      sld.Select
      On Error Resume Next
      Set shp = ActiveWindow.Selection.SlideRange.Shapes.AddPicture( _
        FileName:=strFolder & strImage, _
        LinkToFile:=msoFalse, _
        SaveWithDocument:=msoTrue, _
        Left:=0, _
        Top:=0)
      sh = pres.PageSetup.SlideHeight
      sw = pres.PageSetup.SlideWidth
      oh = shp.Height
      ow = shp.Width
      ' Aspect ratio
      If ow / oh > sw / sh Then
        ' Shape is wide
        shp.Width = sw
        shp.Height = oh / ow * sw
      Else
        ' Shape is tall
        shp.Height = sh
        shp.Width = ow / oh * sh
      End If
      oh = shp.Height
      ow = shp.Width
      ' Center the shape
      shp.Left = (sw - ow) / 2
      shp.Top = (sh - oh) / 2
    End If
    strImage = Dir ' Get next file
  Loop

  ' Set timings to ONE SECOND interval
  If FoundImage Then
    With ActivePresentation.Slides.Range.SlideShowTransition
      .EntryEffect = ppEffectNone
      .AdvanceOnClick = msoFalse
      .AdvanceOnTime = msoTrue
      .AdvanceTime = 1
      .SoundEffect.Type = ppSoundNone
    End With
  End If
End Sub
Best wishes,
Hans