Load BMP/JPG images to PPT slides

[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

[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.

[ChrisGreaves]

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!)

[Rudi]

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

Tx Chris...now I have a warm glow!

[HansV]

Be careful you two don't set the Lounge afire!

[ChrisGreaves]

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 .....

[StuartR]

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

Thank you.

[ChrisGreaves]

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!)

[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

[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