Batch photo insert for reporting

I'm an absolute caveman when it comes to VBA. My skills are capped at scouring forums, copy pasting, and failing repeatedly.

The following is a result of Frankenstein-ing and mild editing but it appears to work at resizing and halfway captioning the images. I would however, like the images to be captioned with the Folder name. Let's say the folder is called 'Basement', how can I get the caption to read 'Figure ## - Basement' where ## is figured magically by the following macro:

Sub Caption()
'
' Caption_Image Macro
'
'
Dim objPic As InlineShape

For Each objPic In ActiveDocument.InlineShapes
objPic.Select
Selection.InsertCaption Label:="Figure", TitleAutoText:="", Title:="", _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0
Next objPic

'
' Resize_Image Macro
'
'
Dim i As Long
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.ScaleHeight = 60
.ScaleWidth = 60
End With
Next i
End With

End Sub

You might try:

https://gregmaxey.com/word_tip_pages...ry_add_in.html

... I have a advanced customized version I sell.

I did check out your site earlier today and was pleased to see the quotes and quips bit - especially regarding Longfellow and the weather. "All sunshine makes desert" ain't it the truth!

I've got a nice thing going now with getting 8 pictures to a page (two columns of four). But it can be better! I'm trying to figure out how to add a piece to the beginning of the macro that will compress the photos to 96dpi. I have tried changing the settings in Word to always import the photos to 96dpi, but when I run the macro without first changing the images to 96dpi from the ribbon, it gets all beefed up. Compress to 96dpi from the ribbon and then run the macro - nice 2x4 columns.

Is there something I can just dump into the top of this that will compress the images for me? As mentioned earlier, I'm full caveman with this:

Sub A_TWO_FOUR_Apartment_203()
'
' Caption_Image Macro
'
'
Dim objPic As InlineShape

For Each objPic In ActiveDocument.InlineShapes
objPic.Select
Selection.InsertCaption Label:="Figure", TitleAutoText:="", Title:=" - Apartment 203", _
Position:=wdCaptionPositionBelow, ExcludeLabel:=0
Next objPic

'
' Resize_Image Macro
'
'
Dim i As Long
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.ScaleHeight = 90
.ScaleWidth = 90
End With
Next i
End With

End Sub