MS Word Caption with the Image Name

问题

The code below works like a charm. It allows the user to pick a folder with .jpgs and other image types into a 2 image per page. The Current code just captions the image as "Picture". What I am needing assistance with is getting the image name as caption minus the .jpg. Any direction would be great:

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

回答1:

It appears vrtSelectedItem provides the information that's required, so the only problem is cutting off the file extension.

This can be done by string manipulation. In the code snippet below, taken from the question, the location of the . in the file name is ascertained, as well as the length of the file name. The Mid function is then used to extract the text to the left of that point.

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

来源：https://stackoverflow.com/questions/58033893/ms-word-caption-with-the-image-name

标签

vba

ms-word