VBA-based macro for PPT that pastes jpeg files onto separate slides

Question

I have a VBA-based macro for PPT that pastes jpeg files onto separate slides (See the 【Macro 1】,below). My question is;

【My Question】
I want to add the following function to 【Macro 1】;
Automatically insert the file name of the pasted image into each slide.

I tried to insert name of files using "ActiveWindow.Selection.SlideRange.Name" etc., but the macro seems to stop if such a description is inserted.

【Macro 1】
You can download original version of this macro from here. This macro is a modified version of Ref1's macro. The linked macro can automatically paste the images to the slides without error, but it doesn't have the ability to use the image name as the slide name.

（modified at 2020/03/29 JST）
The macro on the Box1 below is one of the prototype macros that were created when trying to add the desired functions to the above macro. I modified based on the advice in the answer, but I get a Runtime error. I tried various places to add, but same result.

（modified at 2020/03/31 JST） Here is the completed version: This macro fulfills my requirements described in 【My Question】 successfully. The following (ref2) was very helpful in creating this macro. You can download this version of macro from here

[Box1]（modified at 2020/03/31 JST）

Sub InsertImages()
'Insert all image files from the same level folder
Dim prs As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim txt As PowerPoint.Shape
Dim tmp As PowerPoint.PpViewType
Dim fol As Object, f As Object
Dim fol_path As String
'Store open presentation in prs
Set prs = ActivePresentation

'Cancel if slide show mode
If SlideShowWindows.Count > 0 Then prs.SlideShowWindow.View.Exit

With ActiveWindow
tmp = .ViewType 'Remember window display mode
.ViewType = ppViewSlide
End With

'Get the path of the folder where this ppt file are.
fol_path = ActivePresentation.Path

  'Processing files in the folders
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(fol_path) Then GoTo Fin

For Each f In .GetFolder(fol_path).Files
'Process only JPEG files
Select Case LCase(.GetExtensionName(f.Path))
Case "jpg", "jpeg"
'Add slids
Set sld = prs.Slides.Add(prs.Slides.Count + 1, ppLayoutChartAndText)
sld.Select
'Insert image
Set shp = sld.Shapes.AddPicture(FileName:=f.Path, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=0, _
Top:=0)
With shp
.LockAspectRatio = True 'Fix the aspect ratio

'Fit inserted image to slide size
            If .Width > .Height Then
              .Width = prs.PageSetup.SlideWidth
            Else
              .Height = prs.PageSetup.SlideHeight
            End If
.Select

'Resize image
.Width = .Width * 0.85
.Height = .Height * 0.85
End With

'Center image on slide
With ActiveWindow.Selection.ShapeRange
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With

'Change slide title to file name
sld.Shapes(1).TextFrame.TextRange.Text = f.Name
'Insert Text
'Set txt = sld.Shapes.AddTextbox( _
'Orientation:=msoTextOrientationHorizontal, _
'Left:=600, _
'Top:=50, _
'Width:=250, _
'Height:=10)

'   With txt
'   .Name = "AddedTextBox"
'   .TextFrame.TextRange = "free text"
'   .TextEffect.FontSize = 20
'   End With
End Select
Next
End With
Fin:
ActiveWindow.ViewType = tmp 'Restore window display mode
End Sub

【References】
(Ref.1)指定したフォルダ内の画像ファイルを一括挿入するPowerPointマクロ, written in Japanese.
(Ref.2)パワーポイント　画像挿入　マクロ VBA, written in Japanese.

The code you posted doesn't raise any errors here. Please add the statements that cause an error and indicate which lines they are. — John Korchok
＠John Korchok　This macro doesn't give an error, but it doesn't have the required function "make file name slide title."　 I didn't post erred macros because it showed what seemed to be an infinite loop. — Blue Various
＠John Korchok I modified the macro in [Box1]. This macro gives an error, but I believe that it will not be an infinite loop. — Blue Various

John Korchok John Korchok · Accepted Answer · 2020-03-21T21:43:05

You're adding a blank slide, then trying to write text to a non-existent Title placeholder. Change the layout to ppLayoutObject to get the Title and Content layout.

Then you'll also have to send the picture to the back, because it will be on top of the Title placeholder. The addition of this line will do that:

          With ActiveWindow.Selection.ShapeRange
            .ZOrder msoSendToBack <!--Add this to send image to back-->
            .Align msoAlignCenters, True
            .Align msoAlignMiddles, True
          End With

VBA-based macro for PPT that pastes jpeg files onto separate slides

1 Answers