Fix for Dir Function?

[helpmeinoob]

Hi there, first time posting and have to apologize in advance for my newbie knowledge around VBA and appreciate any help I can get from the forum.

My goal is to run an application in powerpoint that pulls all images from a folder, sizes them and pastes them into a powerpoint template I have created. I thought I found a solution, but did not realize that the Dir function capabilities are limited. I want to be able to paste the images into the template in the order they appear in the folder. I think I can sort using an Array function, but am lost on how to get this going. Here is my basic vba code that works well (except for the paste order). Any insight would be great :) Thanks so much.


Sub ImportPacket()


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


strPath = "O:\Data\File\"
strFileSpec = "*.png"




strTemp = Dir(strPath & strFileSpec)


While strTemp <> ""


For Each oSld In ActivePresentation.Slides
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=30.24, _
Top:=57.6, _
Width:=645.84, _
Height:=446.4)
oPic.ZOrder msoSendToBack
strTemp = Dir
Next




Wend


End Sub

[Paul_Hossler]

Welcome to VBAexpress

You can use the [#] icon to add
... tags and paste your macro between them to format

Try this, but you macro looks like it would put every picture on every slide. Is that what you wanted?



Option Explicit
Sub ImportPacket()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim aPics() As String
Dim aPicsCounter As Long
Dim i As Long, j As Long

' strPath = "O:\Data\File\"
' strFileSpec = "*.png"
strPath = "c:\users\daddy\icons\hi res pngs\animals\256\"
strFileSpec = "*.png"
'load array
aPicsCounter = -1
strTemp = Dir(strPath & strFileSpec)
While strTemp <> ""
aPicsCounter = aPicsCounter + 1
ReDim Preserve aPics(0 To aPicsCounter)
aPics(aPicsCounter) = strTemp
strTemp = Dir
Wend

'bubble sort array
For i = LBound(aPics) To UBound(aPics) - 1
For j = i + 1 To UBound(aPics)
If aPics(i) > aPics(j) Then
strTemp = aPics(i)
aPics(i) = aPics(j)
aPics(j) = strTemp
End If
Next j
Next i

'this seems to put all the pictures onto all of the slides???
For i = LBound(aPics) To UBound(aPics) - 1
For Each oSld In ActivePresentation.Slides
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & aPics(i), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=30.24, _
Top:=57.6, _
Width:=645.84, _
Height:=446.4)
oPic.ZOrder msoSendToBack
Next
Next i
End Sub

[helpmeinoob]

Thanks so much for the response. I think this macro is close to what I have in mind. How are the pictures being sorted? Ideally, the pictures from the folder will be pasted (one per slide) in the order I have them in the folder. Not all on each slide like you mention.

[Paul_Hossler]

The bubble sort as is does it A to Z by Name

You can change the parameters (e.g. modify date, etc.) that it sorts on to match how you have it sorted on disc

[helpmeinoob]

Ok awesome thank you. And is it possible to paste one per slide, not all pictures on every slide?

[Paul_Hossler]

Try this




Option Explicit
Sub ImportPacket()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim aPics() As String
Dim aPicsCounter As Long
Dim i As Long, j As Long

strPath = "O:\Data\File\"
strFileSpec = "*.png"


'load array
aPicsCounter = -1
strTemp = Dir(strPath & strFileSpec)
While strTemp <> ""
aPicsCounter = aPicsCounter + 1
ReDim Preserve aPics(0 To aPicsCounter)
aPics(aPicsCounter) = strTemp
strTemp = Dir
Wend


'bubble sort array
For i = LBound(aPics) To UBound(aPics) - 1
For j = i + 1 To UBound(aPics)
If aPics(i) > aPics(j) Then
strTemp = aPics(i)
aPics(i) = aPics(j)
aPics(j) = strTemp
End If
Next j
Next I


'assumes that there are at least the same number of slides already as pictures
For i = LBound(aPics) To UBound(aPics)
Set oSld = ActivePresentation.Slides(i + 1)
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & aPics(i), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=30.24, _
Top:=57.6, _
Width:=645.84, _
Height:=446.4)
oPic.ZOrder msoSendToBack
Next i
End Sub

[helpmeinoob]

Thanks so much. This is exactly what I've been looking for :clap: