Как макросом вставить фото из файла jpg на лист - и сохранением пропорций, но с ограничением высоты. То есть если высота рисунка - больше указанной в ячейке B3 величины - то картинка уменьшится под эту высоту с сохранением пропорций. А если значение высоты рисунка - меньше значения B3 - то она увеличится с сохранением пропорций.
(Значение новой высоты рисунка при вставке - находится в ячейке B3. Место вставки картинки - в ячейку D5)
Добрый вечер, форумчане. Подскажите с решением.
Как макросом вставить фото из файла jpg на лист - и сохранением пропорций, но с ограничением высоты. То есть если высота рисунка - больше указанной в ячейке B3 величины - то картинка уменьшится под эту высоту с сохранением пропорций. А если значение высоты рисунка - меньше значения B3 - то она увеличится с сохранением пропорций.
(Значение новой высоты рисунка при вставке - находится в ячейке B3. Место вставки картинки - в ячейку D5)rotten41
Sub Вставить_рисунок() Dim strFullName As String, objShape As Shape With Application.FileDialog(msoFileDialogFilePicker) .Filters.Clear .Filters.Add "Рисунки", "*.jpg" If .Show = 0 Then Exit Sub End If strFullName = .SelectedItems(1) End With Set objShape = ActiveSheet.Shapes.AddPicture(strFullName, False, True, Range("D5").Left, Range("D5").Top, -1, -1) objShape.LockAspectRatio = True objShape.Height = Range("B3").value End Sub
[/vba]
[vba]
Код
Sub Вставить_рисунок() Dim strFullName As String, objShape As Shape With Application.FileDialog(msoFileDialogFilePicker) .Filters.Clear .Filters.Add "Рисунки", "*.jpg" If .Show = 0 Then Exit Sub End If strFullName = .SelectedItems(1) End With Set objShape = ActiveSheet.Shapes.AddPicture(strFullName, False, True, Range("D5").Left, Range("D5").Top, -1, -1) objShape.LockAspectRatio = True objShape.Height = Range("B3").value End Sub