PowerPoint VBA to insert Photos not working

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
245
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I have been struggling with this for days and can't figure why it only inserts two photos in the first slide and quits.
I have hundreds of photos to insert stacked two to a page, the THEN & NOW.
Every slide will have a THEN photo & a NOW photo. Jpgs are named "THEN 1234, THEN 2345, THEN 3456 etc. and NOW 1234, NOW 2345, NOW 3456.
I need help figuring out what I am doing wrong that it stops after inserting photos on the first slide.
VBA Code: 
Sub InsertStackedPhotos()
    Dim folderPath As String
    Dim fileName As String
    Dim beforePic As String
    Dim afterPic As String
    Dim slideIndex As Integer
    Dim slide As slide
    Dim shape As shape
    Dim table As table
    Dim picShape As shape

    ' Set the folder path
    folderPath = "C:\Users\path\" 

    ' Initialize slide index
    slideIndex = 2

    ' Initialize picture paths
    beforePic = ""
    afterPic = ""

    ' Loop through the files in the folder
    fileName = Dir(folderPath & "*.jpg")
    Do While fileName <> ""
        Debug.Print "Processing file: " & fileName ' Debug message

        ' Identify "Then" and "Now" photos
        If Left(fileName, 6) = "THEN" Then
            THENPic = folderPath & fileName
            Debug.Print "Found THEN photo: " & THENPic ' Debug message
        ElseIf Left(fileName, 5) = "NOW" Then
            NOWPic = folderPath & fileName
            Debug.Print "Found NOW photo: " & NOWPic ' Debug message
        End If

        ' If both "THEN" and "NOW" photos are found, insert them into the current slide
        If THENPic <> "" And NOWPic <> "" Then
            Debug.Print "Inserting photos into slide " & slideIndex ' Debug message

            ' Check if the slide exists, if not, create a new one
            If slideIndex > ActivePresentation.Slides.Count Then
                Set slide = ActivePresentation.Slides.Add(slideIndex, ppLayoutText)
            Else
                Set slide = ActivePresentation.Slides(slideIndex)
            End If
            slideIndex = slideIndex + 1

            ' Add a table with 2 rows and 1 column to the slide
            Set shape = slide.Shapes.AddTable(2, 1, 0, 144, 612, 576) ' 8.5 inches = 612 points, 8 inches = 576 points
            Set table = shape.table

            ' Set the header row
            table.Cell(1, 1).shape.TextFrame.TextRange.Text = "THEN"
            table.Cell(2, 1).shape.TextFrame.TextRange.Text = "NOW"

            ' Add the "THEN" picture to the first cell
            Set picShape = slide.Shapes.AddPicture(THENPic, msoFalse, msoTrue, 0, 0, -1, -1)
            picShape.LockAspectRatio = msoTrue
            If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
            If picShape.Height > 288 Then picShape.Height = 288 ' 4 inches = 288 points
            ' Center the picture in the cell
            picShape.Top = table.Cell(1, 1).shape.Top + (table.Cell(1, 1).shape.Height - picShape.Height) / 2
            picShape.Left = table.Cell(1, 1).shape.Left + (table.Cell(1, 1).shape.Width - picShape.Width) / 2

            ' Add the "NOW" picture to the second cell
            Set picShape = slide.Shapes.AddPicture(NOWPic, msoFalse, msoTrue, 0, 0, -1, -1)
            picShape.LockAspectRatio = msoTrue
            If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
            If picShape.Height > 288 Then picShape.Height = 288 ' 4 inches = 288 points
            ' Center the picture in the cell
            picShape.Top = table.Cell(2, 1).shape.Top + (table.Cell(2, 1).shape.Height - picShape.Height) / 2
            picShape.Left = table.Cell(2, 1).shape.Left + (table.Cell(2, 1).shape.Width - picShape.Width) / 2

            ' Reset the picture paths for the next iteration
            THENPic = ""
            NOWPic = ""
        End If

        ' Get the next file
        fileName = Dir
    Loop

    Debug.Print "Finished processing all files." ' Debug message
End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
It looks to me like your loop is discovering your files in a different order than you expect. For example, if it returns all of the NOW files first, then all of the THEN files, you will only process one pair of files. What is your debug output showing?

I would program this in a way that does not depend on what order the files are returned. Dir returns files in the order they are stored in the Windows directory, and technically that order is undefined.

VBA Code: 
Sub InsertStackedPhotos()
    Dim folderPath As String
    Dim fileName As String
    Dim beforePic As String
    Dim afterPic As String
    Dim slideIndex As Integer
    Dim slide As slide
    Dim shape As shape
    Dim table As table
    Dim picShape As shape

    ' Set the folder path
    folderPath = "C:\Users\path\"

    ' Initialize slide index
    slideIndex = 2

    ' Initialize picture paths
    beforePic = ""
    afterPic = ""

    ' Loop through the files in the folder
    fileName = Dir(folderPath & "*.jpg")
    Do While fileName <> ""
        Debug.Print "Processing file: " & fileName ' Debug message

        ' Get "Then" photo
        If Left(fileName, 6) = "THEN" Then
            THENPic = folderPath & fileName
            Debug.Print "Found THEN photo: " & THENPic ' Debug message
            
            ' Identify "Now" photo based on "Then" photo name
            NOWPic = folderPath & Replace(fileName, "THEN", "NOW")
        
            Debug.Print "Inserting photos into slide " & slideIndex ' Debug message

            ' Check if the slide exists, if not, create a new one
            If slideIndex > ActivePresentation.Slides.Count Then
                Set slide = ActivePresentation.Slides.Add(slideIndex, ppLayoutText)
            Else
                Set slide = ActivePresentation.Slides(slideIndex)
            End If
            slideIndex = slideIndex + 1

            ' Add a table with 2 rows and 1 column to the slide
            Set shape = slide.Shapes.AddTable(2, 1, 0, 144, 612, 576) ' 8.5 inches = 612 points, 8 inches = 576 points
            Set table = shape.table

            ' Set the header row
            table.Cell(1, 1).shape.TextFrame.TextRange.Text = "THEN"
            table.Cell(2, 1).shape.TextFrame.TextRange.Text = "NOW"

            ' Add the "THEN" picture to the first cell
            Set picShape = slide.Shapes.AddPicture(THENPic, msoFalse, msoTrue, 0, 0, -1, -1)
            picShape.LockAspectRatio = msoTrue
            If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
            If picShape.Height > 288 Then picShape.Height = 288 ' 4 inches = 288 points
            ' Center the picture in the cell
            picShape.Top = table.Cell(1, 1).shape.Top + (table.Cell(1, 1).shape.Height - picShape.Height) / 2
            picShape.Left = table.Cell(1, 1).shape.Left + (table.Cell(1, 1).shape.Width - picShape.Width) / 2

            ' Add the "NOW" picture to the second cell
            Set picShape = slide.Shapes.AddPicture(NOWPic, msoFalse, msoTrue, 0, 0, -1, -1)
            picShape.LockAspectRatio = msoTrue
            If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
            If picShape.Height > 288 Then picShape.Height = 288 ' 4 inches = 288 points
            ' Center the picture in the cell
            picShape.Top = table.Cell(2, 1).shape.Top + (table.Cell(2, 1).shape.Height - picShape.Height) / 2
            picShape.Left = table.Cell(2, 1).shape.Left + (table.Cell(2, 1).shape.Width - picShape.Width) / 2

        End If

        ' Get the next file
        fileName = Dir
    Loop

    Debug.Print "Finished processing all files." ' Debug message
End Sub
 
Upvote 0
6StringJazzer said:
It looks to me like your loop is discovering your files in a different order than you expect. For example, if it returns all of the NOW files first, then all of the THEN files, you will only process one pair of files. What is your debug output showing?

I would program this in a way that does not depend on what order the files are returned. Dir returns files in the order they are stored in the Windows directory, and technically that order is undefined.

VBA Code: 
Sub InsertStackedPhotos()
    Dim folderPath As String
    Dim fileName As String
    Dim beforePic As String
    Dim afterPic As String
    Dim slideIndex As Integer
    Dim slide As slide
    Dim shape As shape
    Dim table As table
    Dim picShape As shape

    ' Set the folder path
    folderPath = "C:\Users\path\"

    ' Initialize slide index
    slideIndex = 2

    ' Initialize picture paths
    beforePic = ""
    afterPic = ""

    ' Loop through the files in the folder
    fileName = Dir(folderPath & "*.jpg")
    Do While fileName <> ""
        Debug.Print "Processing file: " & fileName ' Debug message

        ' Get "Then" photo
        If Left(fileName, 6) = "THEN" Then
            THENPic = folderPath & fileName
            Debug.Print "Found THEN photo: " & THENPic ' Debug message
           
            ' Identify "Now" photo based on "Then" photo name
            NOWPic = folderPath & Replace(fileName, "THEN", "NOW")
       
            Debug.Print "Inserting photos into slide " & slideIndex ' Debug message

            ' Check if the slide exists, if not, create a new one
            If slideIndex > ActivePresentation.Slides.Count Then
                Set slide = ActivePresentation.Slides.Add(slideIndex, ppLayoutText)
            Else
                Set slide = ActivePresentation.Slides(slideIndex)
            End If
            slideIndex = slideIndex + 1

            ' Add a table with 2 rows and 1 column to the slide
            Set shape = slide.Shapes.AddTable(2, 1, 0, 144, 612, 576) ' 8.5 inches = 612 points, 8 inches = 576 points
            Set table = shape.table

            ' Set the header row
            table.Cell(1, 1).shape.TextFrame.TextRange.Text = "THEN"
            table.Cell(2, 1).shape.TextFrame.TextRange.Text = "NOW"

            ' Add the "THEN" picture to the first cell
            Set picShape = slide.Shapes.AddPicture(THENPic, msoFalse, msoTrue, 0, 0, -1, -1)
            picShape.LockAspectRatio = msoTrue
            If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
            If picShape.Height > 288 Then picShape.Height = 288 ' 4 inches = 288 points
            ' Center the picture in the cell
            picShape.Top = table.Cell(1, 1).shape.Top + (table.Cell(1, 1).shape.Height - picShape.Height) / 2
            picShape.Left = table.Cell(1, 1).shape.Left + (table.Cell(1, 1).shape.Width - picShape.Width) / 2

            ' Add the "NOW" picture to the second cell
            Set picShape = slide.Shapes.AddPicture(NOWPic, msoFalse, msoTrue, 0, 0, -1, -1)
            picShape.LockAspectRatio = msoTrue
            If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
            If picShape.Height > 288 Then picShape.Height = 288 ' 4 inches = 288 points
            ' Center the picture in the cell
            picShape.Top = table.Cell(2, 1).shape.Top + (table.Cell(2, 1).shape.Height - picShape.Height) / 2
            picShape.Left = table.Cell(2, 1).shape.Left + (table.Cell(2, 1).shape.Width - picShape.Width) / 2

        End If

        ' Get the next file
        fileName = Dir
    Loop

    Debug.Print "Finished processing all files." ' Debug message
End Sub
Click to expand...
Thank you for your suggestion.
I tried to run your code, however, it stopped at the
VBA Code: 
Set picShape = slide.Shapes.AddPicture(THENPic, msoFalse, msoTrue, 0, 0, -1, -1)

Maybe we should change the wording from THEN & NOW to BEFORE & AFTER instead. I think that one line is an IF THEN and gets confused with THEN & NOW?
For example: the 612 Then, does that mean the THEN photo? It repeats in the NOW section as well.
VBA Code: 
If picShape.Width > 612 Then picShape.Width = 612 ' 8.5 inches = 612 points
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question Question
PowerPoint Run Macro out of SlideShow (Doesnt work in slide mode)
Replies
0
Views
1K
DrHacker
D
B
  • Question Question
Create Powerpoint slides with pictures from Excel database
Replies
0
Views
683
bbrimberry
B
N
  • Question Question
Excel vba to hide powerpoint automation
Replies
0
Views
661
NIPUL JARIWALA
N
J
  • Question Question
import multiple photos from a folders then resize
Replies
3
Views
3K
John_w
J
A
  • Question Question
Export multiple Ranges/Charts to PowerPoint
Replies
1
Views
943
abc_xyz
A

Forum statistics

Threads
1,223,793
Messages
6,174,635
Members
452,575
Latest member
Fstick546

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top