title: MS Word Photo Caption Macro
body: <p>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.</p>
  
  <pre><code>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 &gt; .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
  </code></pre>