|
Требуется макросом поместить изображение (картинку) на лист Excel?
Используйте функцию ВставитьКартинку, которая позволит вам вставить картинку в выбранную ячейку (или диапазон ячеек).
При вызове функции можно задать дополнительные дополнительные параметры, указав, следует ли подгонять картинку (или ячейку) по высоте и ширине.
Если вам требуется вставлять много изображений на лист Excel, - то вам поможет надстройка, позволяющая производить поиск изображений в заданной папке, и производить вставку картинок в ячейки или примечания
Кроме того, надстройка для вставки изображений в Excel умеет загружать картинки из интернета (по ссылкам в таблице Excel)
Бесплатно скачать надстройку вставки картинок в Excel
В этом примере демонстрируются возможные варианты применения функции вставки картинок:
Sub ПримерВставкиИзображенийНаЛист()
ПутьКФайлуСКартинками = "D:\BMP\AboutForm.jpg" ' полный путь к файлу изображения
' вставка картинки в ячейку A5 (размеры картинки и ячейки не меняются)
ВставитьКартинку Cells(5, 1), ПутьКФайлуСКартинками
' вставка картинки в ячейку F5 (ячейка подгоняется по ШИРИНЕ под картинку)
ВставитьКартинку Cells(5, 6), ПутьКФайлуСКартинками, True
' вставка картинки в ячейку E1 (ячейка подгоняется по ВЫСОТЕ под картинку)
ВставитьКартинку [e1], ПутьКФайлуСКартинками, , True
' вставка картинки в ячейку F2 (ячейка принимает размеры картинки)
ВставитьКартинку Range("F2"), ПутьКФайлуСКартинками, True, True
' =========================================
' вставка картинки в ячейку F5 (картинка подгоняется по ШИРИНЕ под ячейку)
ВставитьКартинку Cells(5, 6), ПутьКФайлуСКартинками, True, , True
' вставка картинки в ячейку E1 (картинка подгоняется по ВЫСОТЕ под ячейку)
ВставитьКартинку [e1], ПутьКФайлуСКартинками, , True, True
' вставка картинки в диапазон a2:e3 (картинка вписывается в диапазон)
ВставитьКартинку [a2:e3], ПутьКФайлуСКартинками, True, True, True
End Sub
А вот и сама функция (скопируйте этот код в стандартный модуль, чтобы иметь возможность вставки картинок одной строкой кода из любого макроса):
Sub ВставитьКартинку(ByRef PicRange As Range, ByVal PicPath As String, _
Optional ByVal AdjustWidth As Boolean, _
Optional ByVal AdjustHeight As Boolean, _
Optional ByVal AdjustPicture As Boolean = False)
' ========== функция получает в качестве параметров: ====================
' PicRange - прямоугольный диапазон ячеек, поверх которого будет расположено изображение
' PicPath - полный путь к файлу картинки (файл в формате JPG, BMP, PNG, и т.д.)
' AdjustWidth - если TRUE, то включен режим подбора ширины (подгонка по высоте)
' AdjustHeight - если TRUE, то включен режим подбора высоты (подгонка по ширине)
' AdjustPicture - если TRUE, то подгоняются размеры картинки под ячейку,
' если FALSE (по умолчанию), то изменяются размеры ячейки
On Error Resume Next: Application.ScreenUpdating = False
' вставка изображения на лист
Dim ph As Picture: Set ph = PicRange.Parent.Pictures.Insert(PicPath)
' совмещаем левый верхний угол ячейки и картинки
ph.Top = PicRange.Top: ph.Left = PicRange.Left
K_picture = ph.Width / ph.Height ' вычисляем соотношение размеров сторон картинки
K_PicRange = PicRange.Width / PicRange.Height ' вычисляем соотношение размеров сторон диапазона ячеек
If AdjustPicture Then ' ПОДГОНЯЕМ РАЗМЕРЫ ИЗОБРАЖЕНИЯ под ячейку (оптимальный вариант)
' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
If AdjustWidth Then ph.Width = PicRange.Width: ph.Height = ph.Width / K_picture
' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
If AdjustHeight Then ph.Height = PicRange.Height: ph.Width = ph.Height * K_picture
' AdjustWidth=TRUE и AdjustHeight=TRUE: вписываем картинку в ячейку (без соблюдения пропорций)
If AdjustWidth And AdjustHeight Then ph.Width = PicRange.Width: ph.Height = PicRange.Height
Else ' ИЗМЕНЯЕМ РАЗМЕРЫ ЯЧЕЙКИ под размеры изображения (нежелательно при вставке НЕСКОЛЬКИХ картинок...)
If AdjustWidth Then ' если AdjustWidth=TRUE, то высоту не трогаем - изменяем ширину
PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth * ph.Width / PicRange.Cells(1).Width
While Abs(PicRange.Cells(1).Width - ph.Width) > 0.1 ' точный подбор ширины ячейки
PicRange.Cells(1).ColumnWidth = PicRange.Cells(1).ColumnWidth - 0.2 * (PicRange.Cells(1).Width - ph.Width)
Wend
End If
If AdjustHeight Then ' если AdjustHeight=TRUE, то ширину не трогаем - изменяем высоту
PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight * ph.Height / PicRange.Cells(1).Height
While Abs(PicRange.Cells(1).Height - ph.Height) > 0.1 ' точный подбор высоты ячейки
PicRange.Cells(1).RowHeight = PicRange.Cells(1).RowHeight - 0.2 * (PicRange.Cells(1).Height - ph.Height)
Wend
End If
End If
End Sub
|
