Вставьте картинку в InlineShape

Question

Я пишу документ, в который мне нужно включить много картинок. В процессе работы изображения меняются много раз.

Моя идея заключалась в том, чтобы включить прямоугольники в качестве заполнителей и дать им подходящее имя. Я создал макрос, который выбирает фигуру, удаляет старую картинку и вставляет новую в фигуру.

Sub InsertImage(Shape As String, Picture As String, Hight As Integer)
    Dim shp As Word.Shape
    Dim strFile As String
    Dim strExt As String

    strFile = "C:\Pictures"
    strExt = ".png"

    ActiveDocument.Shapes.Range(Array(Shape)).Select
    Selection.TypeBackspace
    Set shp = ActiveDocument.Shapes.AddPicture(Anchor:=Selection.Range, FileName:= _
         strFile & "\" & Picture & strExt, LinkToFile:=False, SaveWithDocument:=True)
    With shp
        .LockAspectRatio = msoTrue
        .Height = CentimetersToPoints(Hight)
    End With 
End Sub


Sub Insert1()
    InsertImage "Shape01", "Pic01", 10
End Sub

Я хочу это для плавающих фигур, а также для InlineShapes.

Когда я устанавливаю свои заполнители в InlineShapes, строка TypeBackspace удаляет InlineShape, и изображение не вставляется в InlineShape.

Answer 1

Большое спасибо за помощь. После многих проблем решение с таблицами + закладками работает безупречно. Вот код:

Sub InsertPic(Pic As String, Cut As Single)
Dim strFile As String
Dim strExt As String
Dim ils As InlineShape

strFile = "C:\Pictures“
strExt = ".png"

Application.ScreenUpdating = False

ActiveDocument.Bookmarks(Pic).Select
Selection.Delete

Set ils = Selection.InlineShapes.AddPicture(FileName:= _
strFile & "/" & Pic & strExt, _
LinkToFile:=False, SaveWithDocument:=True)

    With ils
    .PictureFormat.CropBottom = CentimetersToPoints(Cut)
    .LockAspectRatio = msoTrue
    .Height = .Range.Cells(1).Height
    If .Width > .Range.Cells(1).Width Then
       .Width = .Range.Cells(1).Width
    End If
    End With

ActiveDocument.Bookmarks.Add (Pic)

Application.ScreenUpdating = True

End Sub


Sub Insert01()
InsertPic "Image01", 20
MsgBox "Done"
End Sub

Некоторые объяснения:

Для этого кода закладке и картинке необходимо одно и то же имя. Я сделал это, чтобы избежать путаницы.

С помощью команды Selection.Delete закладка также удаляется, поэтому я просто добавил новую закладку с тем же именем в конце. Я уверен, что есть более элегантные способы решения этой проблемы, но это решение работает.

У меня было много проблем, потому что я хотел обрезать Picure. Но размер изменяется на размер ячейки таблицы, когда она вставлена, и после этого наступает этап резки. Таким образом, Picturs не заполнял полный размер ячейки. Поэтому я добавил деталь для изменения размера изображения в ячейке таблицы. Кроме того, я уверен, что есть лучшие способы преодолеть это ...

Из-за этого изменения размера Макро требуется немного времени (по крайней мере, для моего документа). Поэтому я отключил функцию обновления экрана.