Заголовок MS Word с названием изображения

Question

Код ниже работает как шарм.Это позволяет пользователю выбрать папку с .jpgs и другими типами изображений в 2 изображения на странице.Текущий код только подписывает изображение как «Изображение».Мне нужна помощь в получении названия изображения в виде подписи минус .jpg.Любое направление было бы замечательно:

Sub AddPic()
Dim fd As FileDialog
Dim oTbl As Table
Dim oILS As InlineShape
Dim vrtSelectedItem As Variant
  '''''''''''''''
  '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:="Picture"
         For Each vrtSelectedItem In .SelectedItems
             With Selection
                 Set oILS = .InlineShapes.AddPicture(FileName:= _
                 vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
                 Range:=Selection.Range)
                 oILS.Range.InsertCaption Label:="Picture", TitleAutoText:="", Title:="", _
                 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

Похоже, vrtSelectedItem предоставляет необходимую информацию, поэтому единственная проблема - обрезать расширение файла.

Это можно сделать с помощью манипуляции со строками.В приведенном ниже фрагменте кода, взятом из вопроса, выясняется расположение . в имени файла, а также длина имени файла.Функция Mid затем используется для извлечения текста слева от этой точки.

Dim dotPos as long, lenName as Long
Dim capt as String

 For Each vrtSelectedItem In .SelectedItems
    dotPos = Instr(vrtSelectedItem, ".")
    lenName = Len(vrtSelectedItem)
    capt = Mid(vrtSelectedItem, lenName + (dotPos - 1 - lenName ))
     With Selection
         Set oILS = .InlineShapes.AddPicture(FileName:= _
           vrtSelectedItem, LinkToFile:=False, SaveWithDocument:=True, _
           Range:=Selection.Range)
         oILS.Range.InsertCaption Label:="Picture", TitleAutoText:="", Title:=capt, _
           Position:=wdCaptionPositionBelow, ExcludeLabel:=0
         .MoveRight wdCell, 1
     End With
 Next vrtSelectedItem