Macro Picture Insert Code to include Filename

[Brandon.wong]

Hi all,

I have a working code that imports selective photos 2 x 3 and provides a caption stating "Picture #" below each imported Photo. I am looking to keep everything the same except change the caption to state the "Filename" without the file extensions. Any help would be greatly appreciated. Thanks much!

The code is as specified below:

Sub AddPics() Application.ScreenUpdating = False
Dim i As Long, j As Long, c As Long, r As Long, NumCols As Long
Dim oTbl As Table, TblWdth As Single, StrTxt As String, RwHght As Single
On Error GoTo ErrExit
NumCols = 2
RwHght = 2.7
On Error GoTo 0
'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
.FilterIndex = 2
If .Show = -1 Then
'Add a 2-row by NumCols-column table to take the images
Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=2, NumColumns:=NumCols)
With ActiveDocument.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With oTbl
.AutoFitBehavior (wdAutoFitFixed)
.Columns.Width = InchesToPoints(3.51)
End With
CaptionLabels.Add Name:="Picture"
For i = 1 To .SelectedItems.Count Step NumCols
r = ((i - 1) / NumCols + 1) * 2 - 1
'Format the rows
Call FormatRows(oTbl, r, RwHght)
For c = 1 To NumCols
j = j + 1
'Insert the Picture
ActiveDocument.InlineShapes.AddPicture _
FileName:=.SelectedItems(j), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oTbl.Cell(r, c).Range
'Insert the Caption on the row below the picture
With oTbl.Cell(r + 1, c).Range
.InsertBefore vbCr
.Characters.First.InsertCaption _
Label:="Picture", Title:=StrTxt, _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
'Exit when we're done
If j = .SelectedItems.Count Then Exit For
Next
'Add extra rows as needed
If j < .SelectedItems.Count Then
oTbl.Rows.Add
oTbl.Rows.Add
End If
Next
Else
End If
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, x As Long, Hght As Single)
With oTbl
With .Rows(x)
.Height = InchesToPoints(Hght)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(x + 1)
.Height = CentimetersToPoints(0.75)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub

[gmayor]

Maybe https://www.gmayor.com/photo_gallery_template.html would help?

[macropod]

I have a working code that imports selective photos
It would be nice if you actually gave some recognition to where you sourced the code. It's also pretty obvious someone's edited the code to delete the part that inserts the filename. See, for example:http://www.vbaexpress.com/forum/showthread.php?60523-Macro-to-insert-4-images-per-page-picture-name-picture-reference-and-additional-row&p=367931


Finally, when posting code, please use the code tags (not VBA tags), indicated by the # button on the posting menu. Without them, your posted code loses much of whatever structure it had.

[Brandon.wong]

It would be nice if you actually gave some recognition to where you sourced the code. It's also pretty obvious someone's edited the code to delete the part that inserts the filename.

Finally, when posting code, please use the code tags (not VBA tags), indicated by the # button on the posting menu. Without them, your posted code loses much of whatever structure it had.

Macropod - Thank you for providing your assistance. My apologizes for not knowing the originating source. This code was "created" by my co-worker who recently left our company.

Graham - I am looking for a macro type solution rather than an add-on package. Thank you for your recommendation and input.