Макрос для вставки фото в excel

Требуется макросом поместить изображение (картинку) на лист Excel?

Используйте функцию ВставитьКартинку, которая позволит вам вставить картинку в выбранную ячейку (или диапазон ячеек).

При вызове функции можно задать дополнительные дополнительные параметры, указав, следует ли подгонять картинку (или ячейку) по высоте и ширине.

В этом примере демонстрируются возможные варианты применения функции вставки картинок:

Sub ПримерВставкиИзображенийНаЛист()
 
    ПутьКФайлуСКартинками = "D:BMPAboutForm.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

Хитрости »

6 Февраль 2020              22758 просмотров

Вставить картинку в лист — по списку или выбору из ячейки

Сама по себе задача вставки картинки на листе не сложная и ответ лежит на поверхности: это доступно прямо из меню: Вставка(Insert) -группа Иллюстрации(Illustrations) —Рисунок(Picture):

Кодом VBA вставить тоже не сложно, даже макрорекордер записывает это действие:

Sub InsertPicture()
    ActiveSheet.Pictures.Insert("G:ДокументыИзображенияExcel_vba_ru.png"). _
        Select
End Sub

Но что делать, если вставить надо картинку из заранее известной папки, но с изменяющимся именем? А если при этом еще надо не просто вставить — а подогнать размер картинки под размер ячейки? Например, в ячейке А2 название товара(соответствует названию картинки), а в В2 должно быть изображение. Здесь уже посложнее. Но тоже вполне реализуемо при помощи VBA

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: вставка в ячейку картинки с подгонкой под размеры ячейки
'---------------------------------------------------------------------------------------
Sub InsertPicToCell()
    'путь к папке с картинками
    Const sPicsPath As String = "G:ДокументыИзображения"
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim oShp As Shape
    Dim zoom As Double
 
    'в этой ячейке выпадающий список с именами картинок
    sPicName = Range("A2").Value
    'если имя картинки не задано
    If sPicName = "" Then
        Exit Sub
    End If
    'проверяем наличие картинки в папке
    sPFName = sPicsPath & sPicName
    If Dir(sPFName, 16) = "" Then
        Exit Sub
    End If
    'в эту ячейку вставляем картинку
    With Range("B2")
        On Error Resume Next
        'задаем картинке уникальный адрес,
        'привязанный к адресу ячейки
        sSpName = "_" & .Address(0, 0) & "_autopaste"
        'если картинка уже есть - удаляем её
        Set oShp = ActiveSheet.Shapes(sSpName)
        If Not oShp Is Nothing Then
            oShp.Delete
        End If
        'вставляем выбранную картинку
        Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
        'определяем размеры картинки в зависимости от размера ячейки
        zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
        oShp.Height = oShp.Height * zoom - 2
        'переименовываем вставленную картинку(чтобы потом можно было заменить)
        oShp.Name = sSpName
    End With
End Sub

Чтобы использовать код необходимо создать в книге стандартный модуль(переходим в редактор VBA(Alt+F11) —Insert —Module) и вставить в него приведенный выше код. Чтобы картинка вставилась в ячейку, надо записать имя картинки в ячейку A2, нажать сочетание клавиш Alt+F8 и выбрать макрос InsertPicToCell. Не очень удобно, правда?
Значит теперь попробуем сделать так, чтобы при каждом изменении в А2 картинка менялась сама, без необходимости запускать каждый раз код вручную. Для этого придется использовать возможность Excel отслеживать такие события, как изменения ячейки(чтобы лучше понять где это лучше сразу прочитать статью Что такое модуль? Какие бывают модули? и особое внимание уделить описанию про модули листов). Теперь чуть переделываем код:

Private Sub Worksheet_Change(ByVal Target As Range)
'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: вставка в ячейку картинки с подгонкой под размеры ячейки
'---------------------------------------------------------------------------------------
    'путь к папке с картинками
    Const sPicsPath As String = "G:ДокументыИзображения"
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim oShp As Shape
    Dim zoom As Double
    'т.к. список с именами картинок у нас в ячейке А2,
    'то определяем, что значение изменилось именно в ней
    '   если в ячейке А2 имена картинок, а список товара в другой ячейке
    '   то надо заменить А2 на ту, которая изменяется списком или руками
    If Intersect(Target, Range("A2")) Is Nothing Then
        'изменения не в А2 - ничего не делаем, завершаем код
        Exit Sub
    End If
    'в этой ячейке выпадающий список с именами картинок
    sPicName = Range("A2").Value
    'если имя картинки не задано
    If sPicName = "" Then
        Exit Sub
    End If
    'проверяем наличие картинки в папке
    sPFName = sPicsPath & sPicName
    If Dir(sPFName, 16) = "" Then
        Exit Sub
    End If
    'в эту ячейку вставляем картинку
    With Range("B2")
        On Error Resume Next
        'задаем картинке уникальный адрес,
        'привязанный к адресу ячейки
        sSpName = "_" & .Address(0, 0) & "_autopaste"
        'если картинка уже есть - удаляем её
        Set oShp = ActiveSheet.Shapes(sSpName)
        If Not oShp Is Nothing Then
            oShp.Delete
        End If
        'вставляем выбранную картинку
        Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
        'определяем размеры картинки в зависимости от размера ячейки
        zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
        oShp.Height = oShp.Height * zoom - 2
        'переименовываем вставленную картинку(чтобы потом можно было заменить)
        oShp.Name = sSpName
    End With
End Sub

Теперь переходим на лист, где в А2 будет изменяться название картинки -правая кнопка мыши на этом листе —Посмотреть код(View Code). Вставляем код выше. Все, теперь при любом изменении в А2 картинка будет изменяться(если указанный файл будет найден в нужной папке).
Если картинки расположены не в «G:ДокументыИзображения», а в той же папке, что и сама книга с кодом, достаточно эту строку
Const sPicsPath As String = «G:ДокументыИзображения»
заменить такими
Dim sPicsPath As String
sPicsPath = ThisWorkbook.Path & «»
тогда папка с книгой будет определяться автоматически.
Но я понимаю, что куда правильнее в ячейке А2 при помощи выпадающего списка выбирать наименование товара, а в В2 при помощи функции ВПР(VLOOKUP) подтягивать из справочника название картинки и уже по этому названию вставлять картинку. Но подстроить код под это уже не сложно. Приводить его здесь не буду, т.к. можно будет запутаться с описанием списка, функций, где и что. Тем более что сам код практически не отличается. К тому же именно в этой реализации код есть в приложенном к статье файле.
Скачать файл:

  Вставить картинку в ячейку (366,9 KiB, 2 393 скачиваний)

И еще часто встречающаяся задача по вставке картинок — это вставка картинок массово. Т.е. вставить картинки на основании значений, записанных в столбце. В данном случае это столбец В. А вставлять картинки будем в столбец С, подгоняя размеры картинок под размер каждой ячейки и проверяя, не вставляли ли мы эту картинку туда ранее

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

'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
'          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
' Purpose: вставка в ячейку картинки с подгонкой под размеры ячейки
'---------------------------------------------------------------------------------------
Option Explicit
 
Sub InsertPictureByVal()
    Dim sPicsPath As String
    Dim sPicName As String, sPFName As String, sSpName As String
    Dim llastr As Long, lr As Long
    Dim oShp As Shape
    Dim zoom As Double
 
    'выбираем путь к папке с картинками
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выбрать папку с картинками"       'заголовок окна диалога
        .ButtonName = "Выбрать папку"
        .Filters.Clear                              'очищаем установленные ранее типы файлов
        .InitialFileName = ThisWorkbook.Path        'назначаем первую папку отображения
        .InitialView = msoFileDialogViewLargeIcons  'вид диалогового окна
        If .Show = 0 Then Exit Sub               'показываем диалог
        sPicsPath = .SelectedItems(1) 'считываем путь к папке
    End With
    '   если путь надо указать статичный - вместо диалога прописываем одну строку
    '   sPicsPath = "C:images"
 
 
    'проверяем, есть ли слеш после пути к папке
    'если нет - добавляем, иначе путь к картинке будет неверный
    If Right(sPicsPath, 1) <> Application.PathSeparator Then
        sPicsPath = sPicsPath & Application.PathSeparator
    End If
    'определяем последнюю ячейку по столбцу с именами картинок
    llastr = Cells(Rows.Count, 2).End(xlUp).Row
    'если кроме шапки в столбце с именами картинок ничего нет
    If llastr < 2 Then
        Exit Sub
    End If
    'цикл по столбцу с именами картинок
    For lr = 2 To llastr
        sPicName = Cells(lr, 2).Value
        'проверяем наличие картинки в папке
        sPFName = sPicsPath & sPicName
        If Dir(sPFName, 16) <> "" And sPicName <> "" Then
            'в эту ячейку вставляем картинку
            With Cells(lr, 3)
 
                'задаем картинке уникальный адрес,
                'привязанный к адресу ячейки
                sSpName = "_" & .Address(0, 0) & "_autopaste"
                'если картинка уже есть - удаляем её
                Set oShp = Nothing
                On Error Resume Next
                Set oShp = ActiveSheet.Shapes(sSpName)
                If Not oShp Is Nothing Then
                    oShp.Delete
                End If
                On Error GoTo 0
                'вставляем выбранную картинку
                Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
                'определяем размеры картинки в зависимости от размера ячейки
                zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
                oShp.Height = oShp.Height * zoom - 2
                'переименовываем вставленную картинку(чтобы потом можно было заменить)
                oShp.Name = sSpName
            End With
        End If
    Next
End Sub

Прикладываю пример в формате ZIP-архива, т.к. вместе с самим файлом с кодом я приложил папку images, которая содержит картинки, используемые для вставки в файле. Папка images и сам файл с кодом должны быть распакованы в одну папку.
Скачать файл:

  Вставить картинку в ячейку (366,9 KiB, 2 393 скачиваний)

Обратная задача — сохранение картинок из листа — уже разбиралась мной в этой статье: Как сохранить картинки из листа Excel в картинки JPG

Так же см.:
Как сохранить картинки из листа Excel в картинки JPG
При вставке из VBA картинки на лист ошибка «Метод paste из класса worksheet завершен неверно»
Как скопировать картинку из примечания?
Копирование картинки из примечания

Статья помогла? Поделись ссылкой с друзьями!

    Видеоуроки

Поиск по меткам



Access
apple watch
Multex
Power Query и Power BI
VBA управление кодами
Бесплатные надстройки
Дата и время
Записки
ИП
Надстройки
Печать
Политика Конфиденциальности
Почта
Программы
Работа с приложениями
Разработка приложений
Росстат
Тренинги и вебинары
Финансовые
Форматирование
Функции Excel
акции MulTEx
ссылки
статистика

Картинка в примечании к ячейке

Хотите использовать фотографию или рисунок в качестве примечания к ячейке? Например, вот так:

Это может быть удобно при создании списков людей с их фотографиями, прайс-листов с изображениями товаров и т.п.

Способ 1. Одиночная вставка

1. Щелкните по ячейке, в которую будем вставлять примечание правой кнопкой мыши и выберите в контекстном меню Добавить примечание (Add comment).
2. Чтобы примечание во время настройки постоянно не пропадало, щелкните по ячейке правой кнопкой мыши и выберите команду Отобразить/Скрыть примечание (Show/Hide Comment).
3. Щелкните правой кнопкой мыши по штрихованной рамке вокруг примечания (штриховка при этом должна превратиться в точки) и выберите в контекстном меню команду Формат примечания (Format Comment).
4. В открывшемся окне перейдите на вкладку Цвета и линии (Colors and Lines) и из раскрывающегося списка Цвет (Color) выберите опцию Способы заливки (Fill Effects):

   

5. В появившемся окне перейдите на вкладку Рисунок (Picture) и, щелкнув по кнопке Рисунок (Select Picture), выберите нужный файл с изображением. Дополнительно можно установить флажок Сохранять пропорции рисунка (Lock picture aspect ratio).
6. Жмем ОК во всех окнах и, возможно, немного подгоняем размеры примечания, чтобы картинку было хорошо видно.

Способ 2. Вставка оптом

Как видно из первого способа, вставка одной картинки в одно примечание — процедура хоть и не сложная технически, но не очень-то быстрая. Поэтому для вставки картинок в массовых масштабах (например, изображений товаров в прайс) лучше использовать простой макрос. В качестве исходных данных примем, что у нас есть:

• список наименований товаров в прайс-листе, к ячейкам которых мы и хотим добавить примечания
• список путей к файлам изображений этих товаров (его можно, кстати, формировать тоже автоматически с помощью вот такого макроса).

Выглядит все это, допустим, так:

Откройте редактор Visual Basic (сочетание клавиш Alt+F11), вставьте новый пустой модуль (меню Insert — Module) и скопируйте туда текст этого макроса:

Sub InsertPicturesInComments()

    Dim rngPics As Range, rngOut As Range
    Dim i As Long, p As String, w As Long, h As Long
    
    Set rngPics = Range("B1:B5")    'диапазон путей к картинкам
    Set rngOut = Range("A1:A5")     'диапазон вывода примечаний
    
    rngOut.ClearComments        'удаляем старые примечания
    
    'проходим в цикле по ячейкам
    For i = 1 To rngPics.Cells.Count
    
        p = rngPics.Cells(i, 1).Value       'считываем путь к файлу картинки
        w = LoadPicture(p).Width            'и ее размеры
        h = LoadPicture(p).Height
        
        With rngOut.Cells(i, 1)
            .AddComment.Text Text:=""       'создаем примечание без текста
            .Comment.Visible = True
            .Comment.Shape.Select True
        End With
        With rngOut.Cells(i, 1).Comment.Shape   'заливаем картинкой
            .Fill.UserPicture p
            .ScaleWidth 1, msoFalse, msoScaleFromTopLeft
            .ScaleHeight h / w * 1.8, msoFalse, msoScaleFromTopLeft     'корректируем размеры
        End With
    Next i
End Sub

Диапазоны rngPics и rngOut можно, естественно, заменить на свои.

Теперь осталось открыть окно управления макросами (Alt+F8) и запустить наш созданный макрос кнопкой Выполнить (Run). Результат будет примерно такой:

Красота!

P.S.

• Вставленные в примечания картинки и фотографии будут неизбежно утяжелять файл. При большом количестве изображений имеет смысл их заранее обработать (сжать до нужных размеров, оптимизировать цветовую гамму и разрешение) с помощью специальных программ.
• Отобразить или скрыть сразу все примечания можно на вкладке Рецензирование — Показать все примечания (Review — Show all comments).
• Удалить все примечания из выделенных ячеек можно на вкладке Главная — Очистить — Примечания (Home — Clear — Comments).

Ссылки по теме

• Что такое макросы, как их использовать, куда вставлять код макроса на VBA

Требуется макросом поместить изображение (картинку) на лист Excel?

Используйте функцию ВставитьКартинку, которая позволит вам вставить картинку в выбранную ячейку (или диапазон ячеек).

При вызове функции можно задать дополнительные дополнительные параметры, указав, следует ли подгонять картинку (или ячейку) по высоте и ширине.

Если вам требуется вставлять много изображений на лист Excel, — то вам поможет надстройка, позволяющая производить поиск изображений в заданной папке, и производить вставку картинок в ячейки или примечания

Кроме того, надстройка для вставки изображений в Excel умеет загружать картинки из интернета (по ссылкам в таблице Excel)

Бесплатно скачать надстройку вставки картинок в Excel

В этом примере демонстрируются возможные варианты применения функции вставки картинок:

Sub ПримерВставкиИзображенийНаЛист()

    ПутьКФайлуСКартинками = "D:BMPAboutForm.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

• 201477 просмотров