PowerPoint VBA to insert Photos not working

N

NeoSez

Board Regular
Joined
Aug 14, 2020
Messages
246
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

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
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
What do you mean it stopped? The code just stopped? Or was there an error message? What was it?

NeoSez said:
I think that one line is an IF THEN and gets confused with THEN & NOW?
Click to expand...
Absolutely not.
 
Upvote 0
6StringJazzer said:
What do you mean it stopped? The code just stopped? Or was there an error message? What was it?


Absolutely not.
Click to expand...
It insertee the table but not any of the photos. No error messages. It just stopped at the lines I specified above when I hit Debug.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,820
Messages
6,181,155
Members
453,021
Latest member
Justyna P

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