Вставка картинки

Public Function PictureCollection() As Collection ' Функция возвращает коллекцию картинок документа
Dim PCol As Collection ' Коллекция представляющая 1 куртинку документа и ее свойства
Dim Shp As Shape, InShp As InlineShape, i As Long
    Set PictureCollection = New Collection ' Создаем новую коллекцию PictureCollection
    For Each Shp In ActiveDocument.Shapes ' Перебираем все объекты Shape
        If Shp.Type = msoLinkedPicture Or Shp.Type = msoPicture Then ' Если Shp связанная картинка или картинка, то
        'Создаем коллекцию PCol
            Set PCol = New Collection
            i = i + 1
                With PCol ' В коллекцию добавляем Элементы
                    .Add Shp, "Object" ' Добавляем объект Shape
                    .Add TypeName(Shp), "Type" ' Добавляем имя типа
                    .Add Shp.Type, "ObjType" ' Добавляем тип картинки
                End With
                    PictureCollection.Add PCol, "Picture_" & i ' Добавляем PCol в PictureCollection
        End If
    Next Shp
    
    ' Аналогично поступаем с объектами InlineShape
        For Each InShp In ActiveDocument.InlineShapes
            If InShp.Type = wdInlineShapeLinkedPicture Or InShp.Type = wdInlineShapePicture Then
            Set PCol = New Collection
            i = i + 1
                With PCol ' В коллекцию добавляем Элементы
                    .Add InShp, "Object" ' Добавляем объект InlineShape
                    .Add TypeName(InShp), "Type" ' Добавляем имя типа
                    .Add InShp.Type, "ObjType" ' Добавляем тип картинки
                End With
                    PictureCollection.Add PCol, "Picture_" & i ' Добавляем PCol в PictureCollection
            End If
        Next InShp
End Function

Public Sub TestPicture() 'Макрос по очереди выделяет картинки документа
Dim Pictures As Collection, PCol As Collection
Dim Pic As Variant
    Set Pictures = PictureCollection
        If Pictures.Count = 0 Then Exit Sub
            For i = 1 To Pictures.Count
                Set PCol = Pictures(i)
                    Set Pic = PCol("Object")
                        Pic.Select
            Next i
End Sub

Sub ShapeBrowserUnprop()
    Dim wid, hig As Double
    Dim objPaint As InlineShape
    For Each objPaint In ActiveDocument.InlineShapes
      'выделили картинку
      objPaint.Select
      'ширина и высота картинки
      'для 17 см в ширину количество пунктов примерно равно 480
      'для стандартной высоты страницы 25,5 см количество пунктов примерно равно 725
      'для увеличенной высоты страницы 28 см количество пунктов примерно равно 780
      'MsgBox objPaint.Width & "  " & objPaint.Height
      If objPaint.Width <> 480 Or objPaint.Height <> 780 Then
        If objPaint.Width > 60 Then
            'непропорциональный пересчет ширины и высоты картинки для страницы 480х780
            objPaint.LockAspectRatio = msoFalse
            objPaint.Width = 480
            objPaint.Height = 780
        Else
           'мелкая картинка – увеличение ширины и высоты картинки в два раза
            objPaint.Width = objPaint.Width * 2
            objPaint.Height = objPaint.Height * 2
            MsgBox objPaint.Width & "  " & objPaint.Height
        End If
      End If
    Next objPaint
End Sub