MS Word Photo Caption Macro

Question

The purpose of this code is to allow the end-use to put two pictures per page. It also has the purpose of putting the last 4 numbers of the photo as the caption minus the ".extension" (ie. .jpg). How do I remove the auto-numbering of the photos and remove the ".jpg" (extension) from the code below? I figured out how to turn off the Picture label.

Sub AddPic()
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
Dim dotPos As Long
Dim lenName As Long
Dim capt As String
  '''''''''''''''
  'Add a 1 row 2 column table to take the images
  '''''''''''''''
Set oTbl = Selection.Tables.Add(Selection.Range, 4, 1)
With oTbl
     .AutoFitBehavior (wdAutoFitWindow)
End With
  '''''''''''''''
Set fda = Application.FileDialog(msoFileDialogFilePicker)
With fda
     .Title = "Select image files and click OK"
     .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
     .FilterIndex = 2
     If .Show = -1 Then
         CaptionLabels.Add Name:=" "
 For Each vrtSelectedItem In .SelectedItems
    dotPos = InStr(vrtSelectedItem, ".")
    lenName = Len(vrtSelectedItem)
    capt = Mid(vrtSelectedItem, lenName + (dotPos - 4 - lenName))

     With Selection
         Set oILS = .InlineShapes.AddPicture(FileName:= _
           vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
           Range:=Selection.Range)
         oILS.Range.InsertCaption Label:=" ", Title:=capt, _
           Position:=wdCaptionPositionBelow, ExcludeLabel:=0
         .MoveRight wdCell, 1
     End With
 Next vrtSelectedItem
If Len(oTbl.Rows.Last.Cells(1).Range) = 2 Then oTbl.Rows.Last.Delete
Set fd = Nothing
End If
End With

  '''''''''''''''
For Each pic In ActiveDocument.InlineShapes
     With pic
         .LockAspectRatio = msoFalse
         If .Width > .Height Then ' horizontal
             .Width = InchesToPoints(5.5)
             .Height = InchesToPoints(3.66)

         Else  ' vertical
             .Width = InchesToPoints(5.5)
         End If
     End With
     Next
  '''''''''''''''
Selection.WholeStory
Selection.Font.Bold = wdToggle
Selection.Font.Bold = wdToggle
Selection.Font.Color = wdColorBlack
  '''''''''''''''
End Sub

Answer 1

The more elegant way is to work with Range objects, such as used in the Answer to your other question . But since you appear to be more comfortable with Selection , I've used that in the code snippet below.

If neither numbering nor a caption label is wanted, it makes no sense to use the InsertCaption functionality, which specifically does those things. Instead, simply insert the text at the desired position (below the picture).

The code does this by selecting the picture, moving one character to the right (pressing the right-arrow key) then inserting the text. Note that the first character is a paragraph mark (pressing Enter), then the caption.

The "last 4 numbers of the photo" - I assume "file name" is meant - can be done by limiting the string Mid returns to four characters. (See the , 4 added to it.)

 For Each vrtSelectedItem In .SelectedItems
    dotPos = InStr(vrtSelectedItem, ".")
    lenName = Len(vrtSelectedItem)
    capt = Mid(vrtSelectedItem, lenName + (dotPos - 4 - lenName), 4)

     With Selection
         Set pic = .InlineShapes.AddPicture(fileName:= _
           vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
           Range:=Selection.Range)
        pic.Range.Select
        .MoveRight wdCharacter
        Selection.Text = vbCr & capt
         .MoveRight wdCell, 1
     End With
 Next vrtSelectedItem