Поиск

Вставка изображения с изменением размера под размер ячейки


Sub InsertPic(ByVal PicLocation As String, ByRef dSH As Worksheet, ByRef PicRange As Range, ByVal num As Integer)
    ''PicLocation - Путь до изображения
    ''dSH - ссылка лист куда вставляем изображение
    ''PicRange -  ссылка на адрес ячейки куда вставляем изображение
    ''num - порядковый номер картинки (нужно в случае своей нумерации изображений в нашем случае "UpdatedImage" & num) 
    Dim sh As Shape
    PicRange.Select
    ''Debug.Print PicRange.MergeArea.Address & " Width=" & PicRange.MergeArea.Width & " Height=" & PicRange.MergeArea.Height
    myHeight = PicRange.MergeArea.Height
    myWidth = PicRange.MergeArea.Width
    Set sh = dSH.Shapes.AddPicture(PicLocation, msoFalse, msoCTrue, 10, 10, -1, -1)
    sh.Top = PicRange.Top
    sh.Left = PicRange.Left
    sh.ScaleHeight 1, 1
    sh.ScaleWidth 1, 1
    sh.LockAspectRatio = 1
    sh.Width = myWidth
    sh.Height = myHeight
    ratio = (sh.Height / sh.Width)
    aspect = (myHeight / myWidth)
    If (ratio < aspect) Then sh.Width = myWidth
    ''Выровнить рисунок по центру
    sh.IncrementLeft (PicRange.MergeArea.Width - sh.Width) / 2
    sh.IncrementTop (PicRange.MergeArea.Height - sh.Height) / 2
    sh.Name = "UpdatedImage" & num
End Sub