creating a new slide for each image

[jwalkerack]

Hi there , i am bit of a novice in Powerpoint VBA. i have done a little bit in VBA in Excel.
i am not sure if its possible , but i was wondering if any one could help me

The main outcome is i have various amount of picture which need to be inserted into one slide per picture. Depending on the presentation some times it could be 4 pictures or some times it could be 40.

i was wondering if it was possible to have a folder where i keep the pictures which would act as loading bay. So i put the pictures into the folder and then run the macro and it inserts each picture into a slide.

i have a template slide that will contain the master header information . So ideally i would like this one to be duplicated and then the picture pasted in. Then duplicating the template slide again and inserting the next picture and so on . Until all of the pictures have been inserted

i was wondering if something like this would be possible , thanks a lot of your time


Jack

[John Wilson]

Definitely possible.

Question though are all the pictures the same size and aspect ratio?

Is there a content placeholder on your template slide?

Important - which version of PowerPoint

[jwalkerack]

Hi John , thank you for the reply . Sorry for the time in getting back to you. The pictures are screen shots , so they are roughly the same size in dimension though this will fluctuate slightly each time . So i guess they would be around the same aspect ratio but would fluctuate as well.

[John Wilson]

And the other two questions???

[jwalkerack]

Hi John , sorry i did not answer you fully there .
The version i am using is 2007 . i am not sure about he content place holder . i m a bit of a novice with the power point terminology . But all that is contained within the template slide is header information , there is also a company header . which is kinda of fixed into the slide. Its like a yellow rectangle at the top . But it is not a shape that you can move and format , it is like its hard wired into the side .

Thanks a lot Jack

[John Wilson]

Try this for a stert.

Make sure you change the FolderPath.


Sub ForEachPic()
Dim rayFileList() As String
Dim FolderPath As String
Dim FileSpec
Dim strTemp As String
Dim x As Long

' EDIT
FolderPath = "C:\Users\John\Desktop\Pics\" ' Note: MUST end in \

FileSpec = "*.jpg"
ReDim rayFileList(1 To 1) As String
strTemp = Dir$(FolderPath & FileSpec)
While strTemp <> ""
rayFileList(UBound(rayFileList)) = FolderPath & strTemp
ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1) As String
strTemp = Dir
Wend
If UBound(rayFileList) > 1 Then
For x = 1 To UBound(rayFileList) - 1
Call MyMacro(rayFileList(x))
Next x
End If
ActivePresentation.Slides(ActivePresentation.Slides.Count).Delete

End Sub

Sub MyMacro(strMyFile As String)
Dim osld As Slide
Dim opic As ShapeRange
Dim opres As Presentation
Set opres = ActivePresentation
Set osld = opres.Slides(opres.Slides.Count)
osld.Duplicate
Set osld = opres.Slides(opres.Slides.Count - 1)
osld.Select
Call osld.Shapes.AddPicture(strMyFile, False, True, 10, 10).Select
Set opic = ActiveWindow.Selection.ShapeRange
opic.Height = 400
opic.Align msoAlignCenters, True
opic.Top = 100
End Sub

[jwalkerack]

Hi John , thanks a lot that works a treat . i guessing the next part be more difficult . Sometimes there are more than one image that will need to uploaded onto the same slide. i guess if there are in the same folder then its hard to show which ones that need to be uploaded. Is there a workaround for doing something like this , if the secondary files had a different file name . such as tiff

[jwalkerack]

Hi John . i tried that again , it works but only creates a new blank slide . it does not duplicate the slide it is started from .

Sorry John , i have tried that again . The first time , its creates blank sides but if tried again it works ok

Thanks a lot jack

[nordeck]

Hi, I am doing similar thing. (office 2010)
I want to make VBA script, which will insert 2 images per presentation page and under images it will write image name )1,2.....100)..
this is working, but I need ordered images by name (it is FEM prezentation, odds are one design and evens are diferent design of part).

here is current version of my script. I am not coder, so there is a lot of junk in it.


Sub aaa()

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 = "path"
strFileSpec = "*.jpg"
strTemp = Dir(strPath & strFileSpec, v)
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, _
'source picture is 1325x922 px
Width:=1325, _
Height:=922)

With opic.PictureFormat
.CropLeft = in2Points(0.05)
.CropRight = in2Points(0.05)
.CropTop = in2Points(0.05)
.CropBottom = in2Points(0.01)
End With
opic.LockAspectRatio = msoTrue
opic.Width = in2Points(4.9)
opic.Top = in2Points(2)
opic.Left = (8)
osld.Shapes.AddShape(msoShapeRectangle, 20, 400, 250, 75) _
.TextFrame.TextRange.Text = strTemp

strTemp = Dir

' nacteni druheho doprava second piscture on right side
Set opic = osld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=1325, _
Height:=922)


With opic.PictureFormat
.CropLeft = in2Points(0.05)
.CropRight = in2Points(0.05)
.CropTop = in2Points(0.05)
.CropBottom = in2Points(0.01)
End With
opic.LockAspectRatio = msoTrue
opic.Width = in2Points(4.9)
opic.Top = in2Points(2)
opic.Left = (360)
osld.Shapes.AddShape(msoShapeRectangle, 400, 400, 250, 75) _
.TextFrame.TextRange.Text = strTemp

strTemp = Dir
Loop
End Sub

Function in2Points(inVal As Single) As Single
in2Points = inVal * 72
End Function


2nd. option is just edit fotoalbum with these pictures (it makes it ordered by name), but I dont know how to select and tak information from Picture

[nordeck]

so I used 2nd option...for english ppt you have to replace obrazek with Picture probably.


Sub doplneni_popisek_move_obrazku()

Dim oshp As Shape 'object variable
Dim x As Long ' we'll use X as a counter
Dim obrazek As String
For x = 2 To ActivePresentation.Slides.Count
Debug.Print ActivePresentation.Slides(x).Name
obrazek = ActivePresentation.Slides(x).Shapes("Obrázek 1").AlternativeText
With ActivePresentation.Slides(x).Shapes("Obrázek 1").PictureFormat
.CropLeft = (1)
.CropRight = (1)
.CropTop = (1)
.CropBottom = (1)
End With
With ActivePresentation.Slides(x).Shapes("Obrázek 1")
.LockAspectRatio = msoTrue
.Width = (350)
.Top = (150)
.Left = (8)
End With
Set oshp = ActivePresentation.Slides(x).Shapes.AddShape(msoShapeRectangle, 40, 400, 250, 75)

With oshp
.TextFrame.TextRange.Text = obrazek
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
With oshp.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With

obrazek = ActivePresentation.Slides(x).Shapes("Obrázek 2").AlternativeText
With ActivePresentation.Slides(x).Shapes("Obrázek 2").PictureFormat
.CropLeft = (1)
.CropRight = (1)
.CropTop = (1)
.CropBottom = (1)
End With
With ActivePresentation.Slides(x).Shapes("Obrázek 2")
.LockAspectRatio = msoTrue
.Width = (350)
.Top = (150)
.Left = (360)
End With
Set oshp = ActivePresentation.Slides(x).Shapes.AddShape(msoShapeRectangle, 400, 400, 250, 75)
With oshp
.TextFrame.TextRange.Text = obrazek
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
End With
With oshp.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With


Next x

End Sub