Insert multiple images and edit titles from text file

[sbaker]

I would like a macro that can read a text file that looks like this:


c:\pictures\pic1.jpg Title of slide
c:\differentfolder\pic14.jpg A different title
c:\yetanotherfolder\pic22.jpg Yet another title
etc.

Then it should insert each picture onto a new slide, and use the text to set the title of the slide.
I have the following code which can create a textbox with the desciptions, but I can't figure out how to change the title of the slide instead. My layout "ppLayoutTitleOnly" has a blank title field ready to be set.


Sub ImportStuffFromFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
strPath = ActivePresentation.Path
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strPath & "\batch.txt", 1, 0) 'batch.txt need to be "Text(Tab delimited)(*.txt)" when saved in Excel
Do While f.AtEndOfStream <> True
picDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=picDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)
'next 4 lines define TextBox(TB) position and dimensions in terms of those of slide
TBPosFromSlideLeftMargin = 0.1 'TB start at 10% of slide width from left to right
TBPosFromSlideTopMargin = 0.8 'TB start at 80% of slide height from top to bottom
TBpercentageOfSlideWidth = 0.8 'TB is 80% of the slide width
TBpercentageOfSlideHeight = 0.2 'TB is 20% of the slide height
Set oDes = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
ActivePresentation.PageSetup.SlideWidth * TBPosFromSlideLeftMargin, _
ActivePresentation.PageSetup.SlideHeight * TBPosFromSlideTopMargin, _
ActivePresentation.PageSetup.SlideWidth * TBpercentageOfSlideWidth, _
ActivePresentation.PageSetup.SlideHeight * TBpercentageOfSlideHeight)
With oDes
.TextFrame.TextRange.Text = picDesc(1)
End With

With oPic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
With oPic
.LockAspectRatio = msoTrue
.Fill.Transparency = 0#
.Height = 0.527 * .Height
.Width = 0.527 * .Width
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = 42
End With
Set oPic = Nothing
Set oDes = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub


If anyone has any suggestions it would be much appreciated!

[John Wilson]

See if this gets you close


Sub ImportStuffFromFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
' declare these
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
strPath = ActivePresentation.Path
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strPath & "\batch.txt", 1, 0) 'batch.txt need to be "Text(Tab delimited)(*.txt)" when saved in Excel
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)

' Do not specify the height / width of the original here
' Default is full size. The method you have used will fail from 2010 and distort images

If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
' I would put the real height here not a fraction of the original
.Height = 0.527 * .Height
.Width = 0.527 * .Width
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 42
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub

[sbaker]

John,
That works beautifully, thank you! Also thanks for fixing my bugs with defining the picture size, I was noticing funny behaviour before.

If I could ask for one improvement, instead of hardcoding the text file (batch.txt), can it prompt me for the filename? I found some code to do an OpenDialog, but I can't quite get it to mesh properly with the existing code:



Dim In_file As Variant
Dim dlgOpen As
FileDialog
Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
dlgOpen.AllowMultiSelect = False
If dlgOpen.Show = -1 Then
In_file = dlgOpen.SelectedItems.Item(1)
End If

[John Wilson]

Something like:


Sub ImportStuffFromFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
' declare these
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0) 'batch.txt need to be "Text(Tab delimited)(*.txt)" when saved in Excel
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)

' Do not specify the height / width of the original here
' Default is full size. The method you have used will fail from 2010 and distort images

If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
' I would put the real height here not a fraction of the original
.Height = 0.527 * .Height
.Width = 0.527 * .Width
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 42
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub

[sbaker]

That works great John, much appreciated!