Vba excel как вставить картинку в ячейку excel - Word и Excel

Вставка существующего рисунка (фигуры, другого объекта) в ячейку Excel с помощью кода VBA. Подгон ячейки под размеры рисунка и фигуры под размеры ячейки.

Подгон ячейки под размеры рисунка

Вставка рисунка в ячейку из кода VBA Excel с подгоном размеров ячейки под размеры фигуры (картинки).

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

Хороший результат при вставке в ячейку небольших изображений дает приравнивание одного символа к пяти точкам.

Код VBA Excel для вставки рисунка в ячейку с подгоном размеров ячейки под размеры фигуры (картинки):

Sub Primer1()

With Лист20

.Shapes(«Рисунок 1»).Placement = xlMove

‘изменяем ширину ячейки (столбца) в символах до 1/5 ширины рисунка в пунктах

.Range(«B3»).ColumnWidth = .Shapes(«Рисунок 1»).Width / 5

‘изменяем высоту ячейки (строки) до высоты рисунка + 10 точек для отступов

.Range(«B3»).RowHeight = .Shapes(«Рисунок 1»).Height + 10

‘задаем отступ рисунка от левого края ячейки на 5 пунктов

.Shapes(«Рисунок 1»).Left = .Range(«B3»).Left + 5

‘задаем отступ рисунка от верхнего края ячейки на 5 пунктов

.Shapes(«Рисунок 1»).Top = .Range(«B3»).Top + 5

End With

End Sub

Свойству Placement объекта Shapes присваиваем значение константы xlMove, которое задает возможность перемещать рисунок вместе с ячейками, но не изменять его размеры при изменении размеров ячеек. Доступные константы из коллекции XlPlacement перечислены ниже.

Было:

Стало:

Подгон фигуры под размеры ячейки

Вставка рисунка в ячейку из кода VBA Excel с подгоном размеров картинки (фигуры) под размеры ячейки.

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

Код VBA Excel для вставки рисунков в ячейки с подгоном размеров картинок (фигур) под размеры ячеек:

Sub Primer2()

Dim i As Byte, n As Single

For i = 1 To 5

With Лист19

‘определяем, во сколько раз будет изменена высота рисунка

n = .Shapes(i).Height / .Cells(i, 1).Height

.Shapes(i).Placement = xlMove

‘изменяем высоту рисунка до высоты ячейки

.Shapes(i).Height = .Cells(i, 1).Height

‘изменяем ширину рисунка пропорционально изменению его высоты

.Shapes(i).Width = .Shapes(i).Width / n

‘выравниваем рисунок по левому краю ячейки

.Shapes(i).Left = .Cells(i, 1).Left

‘выравниваем рисунок по верхнему краю ячейки

.Shapes(i).Top = .Cells(i, 1).Top

End With

End Sub

Было:

Стало:

Константы из коллекции XlPlacement

Константы из коллекции XlPlacement определяют реакцию рисунка, фигуры или другого объекта из группы «Иллюстрации» на перемещение и изменение размеров ячеек, над которыми рисунок расположен.

Описание констант из коллекции XlPlacement:

Константа	Значение	Описание
xlMoveAndSize	1	Объект перемещается и изменяет размеры вместе с ячейками
xlMove	2	Объект перемещается вместе с ячейками, но не изменяет размеры
xlFreeFloating	3	Объект не перемещается и не изменяет размеры вместе с ячейками

Источник

I’m adding «.jpg» files to my Excel sheet with the code below :

'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
    .LockAspectRatio = msoTrue
    .Width = 75
    .Height = 100
End With
'Resize and make printable
With xlApp.Selection
    .Placement = 1 'xlMoveAndSize
    '.Placement = 2 'xlMove
    '.Placement = 3 'xlFreeFloating
    .PrintObject = True
End With

I don’t know what I am doing wrong but it doesn’t get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?

SWa

4,32323 silver badges40 bronze badges

asked Oct 17, 2012 at 14:29

Berker YüceerBerker Yüceer

6,98618 gold badges67 silver badges102 bronze badges

Try this:

With xlApp.ActiveSheet.Pictures.Insert(PicPath)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 75
        .Height = 100
    End With
    .Left = xlApp.ActiveSheet.Cells(i, 20).Left
    .Top = xlApp.ActiveSheet.Cells(i, 20).Top
    .Placement = 1
    .PrintObject = True
End With

It’s better not to .select anything in Excel, it is usually never necessary and slows down your code.

answered Oct 17, 2012 at 14:42

Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()

Dim myPic As Object
Dim picpath As String

picpath = "C:Usersphoto.jpg" 'example photo path

Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)

With myPic
    .Width = 25
    .Height = 25
    .Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
    .Left = xlApp.Cells(i, 20).Left
    .LockAspectRatio = msoFalse
End With

I’m working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error «Argument not optional». Looking at this You may ask why I set Height and Width as -1, but that doesn’t matter cause of those parameters are set underneath between With brackets.

Hope it may be also useful for someone

answered Oct 22, 2019 at 9:17

TeamothyTeamothy

1,9903 gold badges15 silver badges24 bronze badges

If it’s simply about inserting and resizing a picture, try the code below.

For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the «right» place and registering its top and left properties values of the dummy onto double variables.

Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.

Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
    Dim Pic As Picture, Shp as Shape
    Set Pic = wsDestination.Pictures.Insert(FilePath)
    Pic.Name = "myPicture"
    'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
    Set Shp = wsDestination.Shapes("myPicture")
    With Shp
        .Height = 100
        .Width = 75
        .LockAspectRatio = msoTrue  'Put this later so that changing height doesn't change width and vice-versa)
        .Placement = 1
        .Top = 100
        .Left = 100
    End with
End Sub

Good luck!

answered Mar 14, 2017 at 3:40

FCastroFCastro

5916 silver badges7 bronze badges

I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!

Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg

For PC: strPictureFilePath = «E:Dropbox» and strPictureFileName = «TestImage.jpg» and with Mac: strPictureFilePath = «Macintosh HD:Dropbox:» and strPictureFileName = «TestImage.jpg»

Code as Follows:

    On Error GoTo ErrorOccured

    shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select

    ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select

    Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
    Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = 130

answered Jul 17, 2016 at 9:31

TristanTristan

1632 silver badges10 bronze badges

Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son

For Each pic In ActiveSheet.Pictures
    If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
        pic.Delete
    End If
Next pic

ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:

End Sub

With the codes above, the picture is sized according to the cell it is added to.

Details and sample file here : Vba Insert image to cell

answered Jan 24, 2021 at 18:06

kadrleynkadrleyn

3341 silver badge5 bronze badges

I tested both @SWa and @Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!

On Error Resume Next
'
' first and faster method (in Office 2016)
'
    With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = destRange.Width
            .height = destRange.height '222
        End With
        .Left = destRange.Left
        .Top = destRange.Top
        .Placement = 1
        .PrintObject = True
        .Name = imageName
    End With
'
' second but slower method (in Office 2016)
'

If Err.Number <> 0 Then
    Err.Clear
    Dim myPic As Shape
    Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
            LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)

    With myPic.OLEFormat.Object.ShapeRange
        .LockAspectRatio = msoTrue
        .Width = destRange.Width
        .height = destRange.height '222
    End With
End If

answered Jan 31, 2020 at 15:06

DrMarbuseDrMarbuse

77410 silver badges30 bronze badges

Источник

Aumi

20 / 35 / 14

Регистрация: 08.10.2015

Сообщений: 406

Вставка картинки в ячейку программно

07.10.2017, 18:22. Показов 26417. Ответов 5

Метки нет (Все метки)

Здравствуйте,

Есть два столбца: id, рисунок
имя картинки состоит из id. Например, id=111, а рисунок 111.jpg.
Я установила высоту строки=200,
Мой код:

Visual Basic

Public Sub insPic()
 
   Application.ScreenUpdating = False
 
Dim BookID As String, T As String, myDir As String
 
myDir = "C:UsersuserPictures"
ID = Range("A1")
T = ".jpg"
 
ActiveSheet.Shapes.AddPicture Filename:=myDir & ID & T, linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=200, Height:=200
 
Application.ScreenUpdating = True

Дело в том, что картинка вставится в выделенную ячейку. Как сделать, чтобы картинка была в В2?

Было бы вообще замечательно, если подскажите,как сделать так, чтобы циклом вставлялись картинки? ID будут в А1-А10,а рисунки их соответсвенно в В1-В10. Макрос или процедура неважно.

pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

07.10.2017, 19:46

Visual Basic

Private Sub Test()
   Application.ScreenUpdating = False
   Dim iPath$, iCell As Range
   iPath = "C:UsersUserPictures"
   For Each iCell In [A1:A10]
       With ActiveSheet.Pictures.Insert(iPath & iCell & ".jpg")
            .Top = iCell(1, 2).Top:     .Left = iCell(1, 2).Left
            .Width = iCell(1, 2).Width: .Height = iCell(1, 2).Height
       End With
    Next
    Application.ScreenUpdating = True
End Sub

Visual Basic

Private Sub Test2()
   Application.ScreenUpdating = False
   Dim iPath$, iCell As Range
   iPath = "C:UsersUserPictures"
   For Each iCell In [A1:A10]
       ActiveSheet.Shapes.AddPicture iPath & iCell & ".jpg", _
       False, True, iCell(1, 2).Left, iCell(1, 2).Top, iCell(1, 2).Width, iCell(1, 2).Height
    Next
    Application.ScreenUpdating = True
End Sub

Если не хотите, чтобы исходные размеры картинок менялись, то в первом варианте уберите .Width и .Height, а во втором, вместо ширины и длины ячейки просто укажите -1
Если же размеры картинки всё же нужно подогнать под размеры ячеек, то определять каждый раз ширину столбца в цикле, не имеет особого смысла, проще говоря, это можно сделать один раз (перед циклом), а затем использовать полученное значение.

Aumi

20 / 35 / 14

Регистрация: 08.10.2015

Сообщений: 406

08.10.2017, 12:41

[ТС]

pashulka,Благодарю вас за ответ!
Тут дело поменялось, сумеете помочь? Хотят, чтобы это была процедура. Чтобы в ячейке прописывалась формула и вниз тянули.
Не подскажите, как преобразовать? Я начала, вот только не знаю, как возвращаемое значение приткнуть

Visual Basic

 Public Function Pic(v)
   Application.ScreenUpdating = False
   Dim iPath$, iCell As Range
   iPath = "C:UsersUserPictures"
 '  For Each iCell In [A1:A2]
       ActiveSheet.Shapes.AddPicture iPath & v & ".jpg", _
       False, True, iCell(1, 2).Left, iCell(1, 2).Top, iCell(1, 2).Width, iCell(1, 2).Height
  '  Next
    Application.ScreenUpdating = True
End Function

pashulka

4131 / 2235 / 940

Регистрация: 01.12.2010

Сообщений: 4,624

08.10.2017, 13:00

Сообщение было отмечено Aumi как решение

Решение

Visual Basic

Public Function Pic(c As Range)
    ActiveSheet.Shapes.AddPicture "C:UsersUserPictures" & c & ".jpg", _
    False, True, c(1, 2).Left, c(1, 2).Top, c(1, 2).Width, c(1, 2).Height
End Function

Если хотите импортировать картинку с привязкой к ячейке с UDF, то :

Visual Basic

Public Function Pic(c As Range)
    With Application.Caller 'Application.ThisCell
         ActiveSheet.Shapes.AddPicture _
         "C:UsersUserPictures" & c & ".jpg", _
         False, True, .Left, .Top, .Width, .Height
    End With
End Function

Aumi

20 / 35 / 14

Регистрация: 08.10.2015

Сообщений: 406

09.10.2017, 11:10

[ТС]

pashulka, Оба варианта не хотят всавлять картинки.
если я в ячейке пишу =Pic(A1) ,то ошибка значении,
а если второй вариант, то Ошибка-неправильная ссылка на ячейку

Добавлено через 1 час 4 минуты
В первом варианте работает этот

Visual Basic

Public Function Pic(c) As Range
     ActiveSheet.Shapes.AddPicture "C:UsersUserPictures" & c & ".jpg", _
    False, True, c(1, 2).Left, c(1, 2).Top, c(1, 2).Width, c(1, 2).Height
End Function

Но не получается тянуть формулу вниз.
Каждый раз приходится прописывать формулу в В1 и В2

Добавлено через 28 минут
Поняла в чем ошибка, короче формулу нужно писать в соседнем столбце, тогда все тянется вниз и картинки вставляются

mor_sergey

77 / 11 / 0

Регистрация: 28.03.2018

Сообщений: 828

10.06.2020, 13:48

pashulka, pashulka, ребят, ничего подходящего не нахожу…мне нужно по условиям из выпадающих списков строить схемы..картинка в колонке Форма просто для южера…как выглядит….строить нужно из элементов.
пробывал макрокордером….не понял как к это перенять

Visual Basic

1 2	ActiveSheet.Shapes.AddShape(msoShapeFlowchartDecision, 545.25, 39, 72, 48.24). _ Select

Источник

Требуется макросом поместить изображение (картинку) на лист 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 22728 просмотров

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

Сама по себе задача вставки картинки на листе не сложная и ответ лежит на поверхности: это доступно прямо из меню: Вставка(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 392 скачиваний)

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

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

'---------------------------------------------------------------------------------------
' 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 392 скачиваний)

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

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

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

Видеоуроки

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

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

Источник

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

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

Игорь Пользователь Сообщений: 3631 Регистрация: 23.12.2012	Если надо вставить одну картинку: http://excelvba.ru/code/PastePictures Если надо автоматизировать процесс вставки большого числа картинок: http://excelvba.ru/programmes/PastePictures

ESTerekhov Пользователь Сообщений: 58 Регистрация: 02.06.2014	В обоих случая рассказывается, как вписать картинку в одну ячейку, а мне нужно именно в диапазон

Karataev

Пользователь

Сообщений: 2306
Регистрация: 23.10.2014

19.08.2015 19:48:59

ESTerekhov, в коде есть комментарии

код

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

20.08.2015 08:59:13

Цитата
Karataev написал: .ShapeRange

Большое спасибо, работает без ошибок! Только я указал диапазон С1:Х23 а картинка вставляется в Т1:АС23. Отчего такой сдвиг?

Karataev Пользователь Сообщений: 2306 Регистрация: 23.10.2014	ESTerekhov, выложите на форуме полностью код, который вы используете и который дает неправильный результат. Изменено: Karataev — 20.08.2015 09:14:03

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

20.08.2015 10:19:43

Код

Set rng = Range("D1:X23")

tip = Worksheets(1).Cells(28, 5)
For zz = 2 To 50
    If tip = Worksheets(2).Cells(zz, 1) Then
    f = Worksheets(2).Cells(zz, 2)
GoTo nashel
                End If
            Next zz
nashel:
ActiveSheet.Pictures.Delete ' это я удаляю ранее вставленные картинки
Set shp = ActiveSheet.Pictures.Insert("D:slep" & f & ".png").ShapeRange
shp.LockAspectRatio = False
     
    shp.Left = rng.Left
    shp.Top = rng.Top
     
    shp.Height = rng.Height
    shp.Width = rng.Width

Изменено: ESTerekhov — 20.08.2015 10:21:11

Karataev Пользователь Сообщений: 2306 Регистрация: 23.10.2014	ESTerekhov, макрос начинается Sub и заканчивается End Sub. Выложите полностью макрос, который вы используете.

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

20.08.2015 10:38:45

Там просто небольшие расчеты идут

Скрытый текст

Изменено: ESTerekhov — 20.08.2015 10:39:13

Karataev

Пользователь

Сообщений: 2306
Регистрация: 23.10.2014

ESTerekhov, сделайте лучше по-другому. Сделайте новый макрос, оставив в нем только то, что связано с картинкой. Запустите этот макрос и убедитесь, что он неправильно работает, и выложите этот макрос на форуме. Чтобы в коде не было того, что не относится к данной теме.

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

#11

20.08.2015 10:55:09

Убрал все — все равно вставляет картинку не в том диапазоне. Конечный диапазон оказывается как бы сдвинутым на 17 столбцов

Код

Option Explicit

Sub расчет()

Dim zz As Integer, f As String, tip As String
Dim rng As Range, shp As ShapeRange

Set rng = Range("D1:X23")

tip = Worksheets(1).Cells(28, 5)
For zz = 2 To 50
    If tip = Worksheets(2).Cells(zz, 1) Then
    f = Worksheets(2).Cells(zz, 2)
GoTo nashel
                End If
            Next zz
nashel:
ActiveSheet.Pictures.Delete
Set shp = ActiveSheet.Pictures.Insert("D:slep" & f & ".png").ShapeRange
shp.LockAspectRatio = False
     
    shp.Left = rng.Left
    shp.Top = rng.Top
     
    shp.Height = rng.Height
    shp.Width = rng.Width
End Sub

Karataev Пользователь Сообщений: 2306 Регистрация: 23.10.2014	ESTerekhov, у меня не получается воссоздать вашу проблему. Не могу помочь. Нужно, наверное, посмотреть файл и сам рисунок.

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

Приложил файлы, код на втором листе модуля, к нему привязана кнопка «Рассчитать».
На втором листе список и названия картинок. Мне нужно сделать так, чтобы при изменении ячейки E28 автоматически вставлялась соответствующая картинка в область С1:Х23.
Картинки не получилось приложить — слишком большой объем. Нужно на локальном диске D создать папку Slep и туда поместить картинку, для того чтобы все работало, назовите ее kupec или посмотрите в соответствии со списком на втором листе.

Прикрепленные файлы

Ворота.xlsm (62.13 КБ)

Влад Пользователь Сообщений: 1189 Регистрация: 24.12.2012	Извечные грабли на одном и том же… Это «Set rng = Range(«D1:X23″)», по-Вашему, на каком листе диапазон, если Вы код в модуль листа засунули?

Karataev

Пользователь

Сообщений: 2306
Регистрация: 23.10.2014

#15

20.08.2015 12:43:18

ESTerekhov, нашел причину ошибки. Оказывается, если код находится в модуле листа и не указывать лист, то подразумевается не активный лист, а лист, в котором находится код.
Явно указывайте в коде лист:

код

Karataev Пользователь Сообщений: 2306 Регистрация: 23.10.2014	Влад, а во встроенной справке написано об этой особенности? Я в справке нашел только такое: When used without an object qualifier, this property is a shortcut for ActiveSheet.Range (it returns a range from the active sheet; if the active sheet isn’t a worksheet, the property fails).

ESTerekhov Пользователь Сообщений: 58 Регистрация: 02.06.2014	Спасибо, все работает теперь)))

Влад

Пользователь

Сообщений: 1189
Регистрация: 24.12.2012

#18

20.08.2015 14:43:39

Цитата
Karataev написал: this property is a shortcut for ActiveSheet.Range

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

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

Можно мне еще спросить про картинки тут, чтобы не плодить новые темы?
1) У меня есть выпадающий список (в файле ячейка E28), как сделать так, чтобы макрос запускался отдельно при выборе нового значения из этого списка?
2) Можно ли запрограммировать перемещение картинки по листу по условию?

Влад Пользователь Сообщений: 1189 Регистрация: 24.12.2012	1. Вызов макроса повесить на событие изменения листа 2. Можно.

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

#21

20.08.2015 15:56:47

Пробую вот таким вот образом — игнорит. Ошибку не выдает, просто ничего не происходит

Скрытый текст

По поводу второго вопроса, как двигать конкретные изображения, если их будет несколько на листе?

Влад Пользователь Сообщений: 1189 Регистрация: 24.12.2012	Сдается мне, у Вас тут путаница с листами — проверьте, какие объекты с какого листа обрабатываются. По поводу перемещения изображений — обращайтесь к ним по названию или по индексу и делайте что хотите.

ESTerekhov Пользователь Сообщений: 58 Регистрация: 02.06.2014	Подскажите, пожалуйста еще один момент. Как при помощи VBA поместить только что вставленную картинку на задний или передний план?

JayBhagavan Пользователь Сообщений: 11833 Регистрация: 17.01.2014 ПОЛ: МУЖСКОЙ \| Win10x64, MSO2019x64	ESTerekhov, воспользуйтесь макрорекордером. <#0> Формула массива (ФМ) вводится Ctrl+Shift+Enter Memento mori

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

#25

25.08.2015 09:45:26

Цитата
JayBhagavan написал: ESTerekhov, воспользуйтесь макрорекордером

Никак не получается сделать так, чтобы картинка сразу вставлялась на задний или на передний план.
Может есть функция какая? Подскажите, пожалуйста

JayBhagavan

Пользователь

Сообщений: 11833
Регистрация: 17.01.2014

ПОЛ: МУЖСКОЙ | Win10x64, MSO2019x64

#26

25.08.2015 09:56:34

ESTerekhov, команды от макрорекордера:

Код
Selection.ShapeRange.ZOrder msoSendToBack Selection.ShapeRange.ZOrder msoBringToFront

<#0>
Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori

ESTerekhov Пользователь Сообщений: 58 Регистрация: 02.06.2014	Да, но компилятор ругается, так как на листе вставлено несколько изображений. Мне нужно не меняя остальные, добавлять новые и удалять некоторые другие

JayBhagavan Пользователь Сообщений: 11833 Регистрация: 17.01.2014 ПОЛ: МУЖСКОЙ \| Win10x64, MSO2019x64	ESTerekhov, покажите код и обозначьте место, где ругается. <#0> Формула массива (ФМ) вводится Ctrl+Shift+Enter Memento mori

ESTerekhov

Пользователь

Сообщений: 58
Регистрация: 02.06.2014

#29

03.09.2015 09:05:43

Цитата
JayBhagavan написал: ESTerekhov, покажите код и обозначьте место, где ругается

уже не ругается, я немного по другому сделал)))
Я, возможно, нелогичен, но у меня теперь обратный вопрос: как сделать так, чтобы программа удаляла все вставленные изображения из определенного диапазона ячеек

Игорь Пользователь Сообщений: 3631 Регистрация: 23.12.2012	#30 03.09.2015 09:32:09 вместо того, чтобы писать макросы, почитайте, как реализовать всё без макросов: http://www.planetaexcel.ru/techniques/1/39/

Источник

3 ответа

Попробуйте следующее:

With xlApp.ActiveSheet.Pictures.Insert(PicPath)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 75
        .Height = 100
    End With
    .Left = xlApp.ActiveSheet.Cells(i, 20).Left
    .Top = xlApp.ActiveSheet.Cells(i, 20).Top
    .Placement = 1
    .PrintObject = True
End With

Лучше не отбирать ничего в Excel, обычно это никогда не нужно и замедляет ваш код.

SWa
17 окт. 2012, в 16:16

Если вы просто вставляете и изменяете размер изображения, попробуйте код ниже.

Для конкретного заданного вами вопроса свойство TopLeftCell возвращает объект диапазона, связанный с ячейкой, где расположен верхний левый угол. Чтобы разместить новое изображение в определенном месте, я рекомендую создать изображение в «правильном» месте и зарегистрировать его верхние и левые значения свойств манекена на двойные переменные.

Вставьте свой Pic, назначенный переменной, чтобы легко изменить его имя. Объект формы будет иметь то же имя, что и объект изображения.

Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
    Dim Pic As Picture, Shp as Shape
    Set Pic = wsDestination.Pictures.Insert(FilePath)
    Pic.Name = "myPicture"
    'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
    Set Shp = wsDestination.Shapes("myPicture")
    With Shp
        .Height = 100
        .Width = 75
        .LockAspectRatio = msoTrue  'Put this later so that changing height doesn't change width and vice-versa)
        .Placement = 1
        .Top = 100
        .Left = 100
    End with
End Sub

Удачи!

FCastro
14 март 2017, в 04:55

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

Примечание: переменные strPictureFilePath и strPictureFileName должны быть установлены на допустимые пути к ПК и Mac Eg

Для ПК: strPictureFilePath = «E:Dropbox » и strPictureFileName = «TestImage.jpg» и с Mac: strPictureFilePath = «Macintosh HD: Dropbox:» и strPictureFileName = «TestImage.jpg»

Код в соответствии с инструкциями:

    On Error GoTo ErrorOccured

    shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select

    ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select

    Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
    Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
    Selection.ShapeRange.LockAspectRatio = msoTrue
    Selection.ShapeRange.Height = 130

Tristan
17 июль 2016, в 11:26

Ещё вопросы

0Неправильный заголовок HTTP в PHP
1Переключить фокус с формы C # на Google Chrome
1Лучший способ хранить данные в виде таблицы
0Javascripts и стили загружаются на каждой странице, одной или отдельных страницах?
0Сортировка многомерного массива PHP по алфавиту [дубликаты]
1Как автоматически вставлять и анализировать элементы XML с помощью любого скрипта (python / shell)?
0Попытка сохранить каждый массив в текстовый файл с помощью php
0получить результат из PHP SQL, но мое «сообщение о результате» не отображается
0Установить HTML-таблицу, четную ширину столбца 2X четных строк
1Разобрать f как строку в json
0MySQL Queries хранится в одной таблице для обновления значений в другой таблице
0различия в использовании массива и верхней памяти
1Как повторно заархивировать файл ODT в C # и сделать его читабельным?
0программное переименование листа Excel без API
1Рефакторинг ссылочной переменной в части кода в Eclipse
1Почему Python Event.wait () может прерываться сигналами в некоторых системах, но не в других?
0Uncaught Error: [$ инжектор: modulerr] с использованием фильтра angularjs
0Микроданные для CreativeWork
1Как расплавить колонну первого уровня в мультииндекс с пандами
0Почему и когда мы должны использовать аргумент. Длина в ember.js
0php curl: вернуться на страницу входа
0Материализация CSS мобильного меню с помощью UI-роутера
0AngularJS — Как сделать токен недоступным из-за консольных или вредоносных атак?
1Webpack не генерирует исходные карты
1Matplotlib pyplot: возможно ли иметь экспоненциальную ось?
0Как оживить div, чтобы появиться и переместиться над другим div
1Мобильная архитектура: на основе Xamarin: как создать мобильное приложение, ориентированное на данные? (например, с помощью Xamarin.Forms / REST)?
0Создание немодального листа свойств с использованием массива страниц свойств MFC C ++
0Невозможно поймать исключение SQL
0Использование функции getGeneratedKeys JDBC в многопоточной среде
1Как преобразовать время в миллисекундах в разное местное время, используя часовой пояс
1WPF XMLDataProvider не работает для объединения XPath
0Преобразование размещения / освобождения многомерных массивов из C ++ в C
0C ++: нарушение доступа
1Упорядочить по разным результатам
1Преобразовать растровое изображение в формат JPEG без использования WriteableBitmap или аналогичного в приложении Windows Phone 8?
0Учимся у C Primer. Ожидаемая ошибка выражения Xcode
1Есть ли способ использовать строку сборки и номер сборки одновременно при сборке пакетов Conda
0очистить тип ввода текста при очистке другого ввода
1конвертировать списки для настройки словаря в Python
1Как программно возобновить активность Android из фона
0центрирование div, даже если содержимое шире экрана
1Как объединить кортежи в python
0сохранение нового пользователя в БД
1Почему это не создает файл?
1Android — создайте схему для моего приложения, которая будет открываться по ссылке на веб-странице
1CSS в мобильном приложении
0Как объединить столбцы из двух таблиц и псевдоним, созданный условным оператором?
0как сообщить, что область видимости обновлена в angularjs?

Источник

Вставка картинки согласно параметрам ячейки

Gopronotmore

Дата: Понедельник, 20.04.2020, 19:28 |
Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183

Репутация:
1
±

Замечаний:
0% ±

Excel 2007

Друзья, добрый вечер.

Я плохо разбираюсь в VBA, но нужно сделать макрос вставки картинки в ячейку.

1 Вопрос. При отмене вставки выпадает ошибка, как ее убрать.
2 Вопрос. Как прописать Width:= xxx Height:= xxx согласно размерам ячейки.

Файл прилагаю

Заранее спасибо

К сообщению приложен файл:

0381247.xlsm
(20.1 Kb)

Ответить

_Boroda_

Дата: Понедельник, 20.04.2020, 20:02 |
Сообщение № 2

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Так нужно?

[vba]

Код

Sub InsertPicUsingShapeAddPictureFunction()
    Dim profile     As String
    On Error Resume Next
    Dim fd          As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add «Picture Files», «*.bmp;*.jpg;*.gif;*.png»
        .ButtonName = «Select»
        .AllowMultiSelect = False
        .Title = «Choose Photo»
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    With ActiveSheet.Range(«D2»)
        ActiveSheet.Shapes.AddPicture Filename:=fd.SelectedItems(1), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoCTrue, _
            Left:=.Left + 2, _
            Top:=.Top + 2, _
            Width:=.Width, _
            Height:=.Height
    End With
End Sub

[/vba]

Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

Gopronotmore

Дата: Понедельник, 20.04.2020, 20:11 |
Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183

Репутация:
1
±

Замечаний:
0% ±

Excel 2007

_Boroda_, да. Спасибо Вам большое

Ответить

_Boroda_

Дата: Понедельник, 20.04.2020, 20:22 |
Сообщение № 4

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Только обратите внимание, что если несколько раз вставлять картинки, то предыдущая не удаляется и в итоге получится, что у Вас в ячейке будет куча картинок, наложенных друг на дружку
Вот так попробуйте
[vba]

Код

Sub InsertPicUsingShapeAddPictureFunction()
    Dim profile     As String
    On Error Resume Next
    Dim fd          As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Filters.Clear
        .Filters.Add «Picture Files», «*.bmp;*.jpg;*.gif;*.png»
        .ButtonName = «Select»
        .AllowMultiSelect = False
        .Title = «Choose Photo»
        .InitialView = msoFileDialogViewDetails
        .Show
    End With
    With ActiveSheet.Range(«D2»)
        For Each as_ In ActiveSheet.Shapes
            If as_.Left = .Left + 2 Then
                as_.Delete
                Exit For
            End If
        Next as_
        ActiveSheet.Shapes.AddPicture Filename:=fd.SelectedItems(1), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoCTrue, _
            Left:=.Left + 2, _
            Top:=.Top + 2, _
            Width:=.Width, _
            Height:=.Height
    End With
End Sub

[/vba]

Ответить

Gopronotmore

Дата: Понедельник, 20.04.2020, 21:38 |
Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183

Репутация:
1
±

Замечаний:
0% ±

Excel 2007

_Boroda_, это вообще шикарно!

Спасибо большое за крутой лайф хак

Ответить

Gopronotmore

Дата: Вторник, 21.04.2020, 16:36 |
Сообщение № 6

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183

Репутация:
1
±

Замечаний:
0% ±

Excel 2007

_Boroda_, Подскажите пожалуйста, если надо вставить фото в Ячеку D2 и в ячеку E2, F2, G2. Что бы выбирал ячейку и потом нажимал вставить фото и фотка вставлялась в выбранную ячейку. Как это реализовать ?

К сообщению приложен файл:

primer.xlsm
(21.1 Kb)

Сообщение отредактировал Gopronotmore — Вторник, 21.04.2020, 16:38

Ответить

_Boroda_

Дата: Вторник, 21.04.2020, 16:53 |
Сообщение № 7

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Так нужно?

Ответить

Gopronotmore

Дата: Вторник, 21.04.2020, 19:07 |
Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183

Репутация:
1
±

Замечаний:
0% ±

Excel 2007

_Boroda_, да спасибо болошьшое. А у меня вопрос. Мы прописываем строгий диапазон ячеек. А можно как-то от него отойти ? Или всегда нужно будет его прописывать ?

Ответить

_Boroda_

Дата: Вторник, 21.04.2020, 19:15 |
Сообщение № 9

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618

Репутация:
6465
±

Замечаний:
0% ±

2003; 2007; 2010; 2013 RUS

Слушайте, Вы сами написали

надо вставить фото в Ячеку D2 и в ячеку E2, F2, G2

А теперь отойти нужно
Держите. Кстати, теперь можно выделять несколько ячеек, вставлять картинку будет в левую верхнюю
И да, в предыдущем файле (если будете им пользоваться) раскомментируйте строку
[vba][/vba]

Ответить

Gopronotmore

Дата: Вторник, 21.04.2020, 19:33 |
Сообщение № 10

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 183

Репутация:
1
±

Замечаний:
0% ±

Excel 2007

_Boroda_, спасибо большое. Просто я думал, запросив в выбранную ячейку, смогу исправить код, что бы в каждую вмещалась картинка. Но нет не получилось! Спасибо большое!

Ответить

Источник