MS Word Photo Caption Macro - PullRequest
Новая
       80

MS Word Photo Caption Macro

0 голосов
/ 25 октября 2019

Цель этого кода - дать конечному пользователю возможность разместить две картинки на странице. Он также имеет целью поместить последние 4 номера фотографии в качестве заголовка минус ".extension" (т.е. .jpg). Как убрать автонумерацию фотографий и удалить «.jpg» (расширение) из кода ниже? Я разобрался, как отключить ярлык Picture. 

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

1 Ответ

1 голос
/ 28 октября 2019

Более элегантный способ - работать с Range объектами, например, используемыми в Ответе на другой вопрос . Но поскольку вам кажется, что вам удобнее использовать 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
...