Insert batch of pictures into Powerpoint slides sorted by name

**plantpol** · 11-27-2017, 02:21 PM

Hi ! I am new at VBA, and I have been trying to find a code to insert a batch of pictures into Powerpoint (2010) slides sorted by name. I found this code on http://www.pptfaq.com/FAQ00352_Batch..._per_slide.htm which works fine but it seems to be inserting the pictures a random order, I want the pictures to be sorted alphabetically by name like I see them when I go into the folder. Here is the code:

Private Sub CommandButton24_Click()

Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

' Edit these to suit:
strPath = "H:\Pictures\"
strFileSpec = "*.*"

strTemp = Dir$(strPath & strFileSpec)

Do While strTemp <> ""
    Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
    Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=0, _
    Top:=0, _
    Width:=-1, _
    Height:=-1)
    ' width/height of -1 tells PPT to import the image at its "natural" size

' Optionally, make it fill the slide - even if that means changing the proportions of the picture
' To do that, uncomment the following:
  With oPic
      .LockAspectRatio = msoFalse
      .Height = ActivePresentation.PageSetup.SlideHeight
      .Width = ActivePresentation.PageSetup.SlideWidth
  End With

' Optionally, add the full path of the picture to the image as a tag:
With oPic
  .Tags.Add "OriginalPath", strPath & strTemp
End With

    ' Get the next file that meets the spec and go round again
    strTemp = Dir$
Loop

End Sub

The file names I want in order are in this format: Image3, Image 4, Image 9, etc.

Thank you so much!

**kev_** · 11-27-2017, 06:02 PM

Welcome to the forum

Your file names are the issue
They are being sorted as text 1, 11, 12, 13......2, 21, 22, 23.....3 etc

To remove your issue rename the files to a consistent format..
Image 001.jpg, Image 002.jpg etc

would you like some VBA to do that? (tomorrow - UK)

**plantpol** · 11-28-2017, 09:38 AM

Hi !

Yes that would definitely help! Thanks

However, some of my files are not sequential (e.g. sometimes it goes from Image 3 to Image 6) but the image numbers need to stay the same because the user will have to know what the exact image number is.

**kev_** · 11-28-2017, 06:36 PM

OK - been busy today. But will post something tomorrow

**kev_** · 11-29-2017, 05:02 AM

Sub ReName (see below) works for me
- my sample data has not been cleared from attached workbook
- your file names may have some oddities that you have not mentioned!
- amended VBA TestReName also included in the attached file
- run with {CTRL} K
- amend the folder path first (must end with "\")
- old values are cleared by the VBA each time
- TestReName dumps values to the 2 worksheets but does not rename any files

The VBA looks at all files in the folder (with *.*)

- to only consider jpegs, amend this line:
fileStr = Dir(InvFolder & "*.*")
- to:
fileStr = Dir(InvFolder & "*.jpg")

If TestReName does what you need you can either:
- run ReName
OR
- amend TestReName

-by removing the comment apostrophe at beginning of the line

'Name InvFolder & fileStr As InvFolder & newFileStr     'REMOVE COMMENT FLAG TO ACTIVATE

Name InvFolder & fileStr As InvFolder & newFileStr

If TestReName does not do exactly what you need, then re-attach the workbook with your data and highlight problem names
(there may be extra spaces etc in your file names)

Const InvFolder = "C:\TestArea\Invoices\"                 'AMEND
Sub ReName()

    Dim fileStr As String, newFileStr As String, oldNum As String, newNum As String, InvFolder As String
    Dim x As Variant, a As Integer, c As Integer
    
    Sheets(1).UsedRange.ClearContents
    InvFolder = "C:\TestArea\Invoices\"     'AMEND
    fileStr = Dir(InvFolder & "*.*")
    
    Do Until fileStr = ""
        oldNum = ""
            For c = 1 To Len(fileStr)
                x = Mid(fileStr, c, 1)
                If x <> "" And IsNumeric(x) Then
                    oldNum = oldNum & x
                End If
            Next c
        newNum = Format(oldNum, "00000")
        newFileStr = Replace(fileStr, oldNum, newNum)
   
'write record to sheet
        a = a + 1
        With Sheets(1)
            .Cells(a, 1) = fileStr
            .Cells(a, 2) = newFileStr
        End With
'rename files
        Name InvFolder & fileStr As InvFolder & newFileStr
        
        fileStr = Dir
    Loop

End Sub