vba - MS Word 照片标题宏

Question

此代码的目的是允许最终用户每页放置两张图片。它还具有将照片的最后 4 个数字作为标题减去“.extension”（即 .jpg）的目的。如何删除照片的自动编号并从下面的代码中删除“.jpg”（扩展名）？我想出了如何关闭图片标签。

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

标签： vbams-word

Answer 1

更优雅的方式是使用Range对象，例如在Answer to your other question中使用的对象。但由于您似乎更喜欢Selection，所以我在下面的代码片段中使用了它。

如果既不需要编号也不需要标题标签，则使用InsertCaption专门执行这些操作的功能是没有意义的。相反，只需在所需位置（图片下方）插入文本。

代码通过选择图片、向右移动一个字符（按右箭头键）然后插入文本来完成此操作。请注意，第一个字符是段落标记（按 Enter），然后是标题。

“照片的最后 4 个数字”——我假设是“文件名”——可以通过将字符串Mid返回限制为四个字符来完成。（见, 4添加到它。）

 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