Требуется макросом поместить изображение (картинку) на лист Excel? Используйте функцию ВставитьКартинку, которая позволит вам вставить картинку в выбранную ячейку (или диапазон ячеек). При вызове функции можно задать дополнительные дополнительные параметры, указав, следует ли подгонять картинку (или ячейку) по высоте и ширине. Если вам нужна надстройка, позволяющая производить поиск изображений в заданной папке, и производить вставку картинок в ячейки или примечания, - то вы можете скачать её здесь: http://excelvba.ru/code/InsertPicturesEx В этом примере демонстрируются возможные варианты применения функции вставки картинок: 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
|
|||
Комментарии
Александр, а какое отношение ваш вопрос имеет к теме статьи (к вставке картинок на лист Excel)?
Обратитесь на форумы по Excel - там вам подскажут.
как уменьшить текс в exele и копировать в word
Здравствуйте,
можете ли подсказать какими макрокомандами можно менять положение желтого ромбика на вставленный кубик? (msoShapeCube)
Картинка меняется - код вроде правильный.
Вот только пока макрос не закончит свою работу, Excel может не обновлять картинку на элементе Image1
(вроде как-то сталкивался с подобным)
Т.е. только когда цикл завершился, Excel вспоминает, что надо перерисовать картинку в Image1.
Как с этим бороться - не знаю. Если честно, вообще не понимаю, какой смысл менять картинку в цикле. Вы таким образом пытаетесь воспроизвести фильм? )
PS: А какое отношение ваш вопрос имеет к теме статьи?
Здравствуйте,
хотела, чтобы картинка менялась в цикле, но получается только в конце цикла картинка отображает последний путь, а во время цикла не меняется
x = 0
While x < 21
Sheet7.Activate
a = Лист2.Cells(2 + x, 2)
Sheet7.Cells(4, 6).Value = a
Sheet7.Cells(4, 10).Value = Лист2.Cells(2 + x, 3)
curfolder = current
p = ActiveWorkbook.Path & "\img\" & a & ".jpg"
Sheet7.Cells(4, 25).Value = p
p2 = ActiveWorkbook.Path & "\img\no.jpg"
If Dir(p, vbDirectory) <> "" Then
Sheet7.Image1.Picture = LoadPicture(p)
Else:
Sheet7.Image1.Picture = LoadPicture(p2)
End If
Sheet7.Cells(5 + x, 1).Value = Dir(p, vbDirectory)
x = x + 1
Application.Wait Now() + TimeValue("00:00:01")
Wend
Проверить, как была вставлена картинка, вряд ли получится.
Вставленная макросом, и добавленная вручную, картинки могут ничем не отличаться...
Проверить файл на существование, если известен полный путь к файлу картинки, очень просто:
if Dir("полный путь к файлу")<>"" then msgbox "Файл существует"
Честно говоря, не понял, как связаны между собой эти 2 вопроса...
Подскажите пожалуйста, можно ли как проверить была ли вставлена картинка методом ActiveSheet.Pictures.Insert или же нет? Возможно проще проверить существует ли файл с фотографией перед ее вставкой? Способ так же мне неизвестный. Просветите пожалуйста...
Спасибо большое администратору за оказанную помощь!!! Но у меня есть еще маленький вопросик:
у меня есть такой код (см. ниже) который из ячейки D3 берет значение пути к картинке (путь к картинке проставляется внешней программой) и вставляет картинку в ячейку E3. При чем вставляет в левый верхний угол.
1) Из этой статьи не совсем разобрался как сделать в моем коде так, чтобы ячейка принимала размер картинки, но чтобы картинки больше 100 на 50 пикселей сжимались до этого размера, и только после этого ячейка могла бы принять размер картинки.
2) Как мне оптимизировать этот код, чтобы макрос определял, какие ячейки в колонке D заполнены (например с 3 по 15 или с 3 по 26) и заполнял картинками колонку E тоже с 3 по 15 или с 3 по 26 соответственно?
With ActiveSheet.Pictures.Insert([D3])
.Top = [E3].Top
.Left = [E3].Left
.Name = [E3]
End With
Я только что направил Вам проект ТЗ о витринах и прилавках.
К ТЗ приложен файл "ИД.Витрина...". В нем динамически меняющиеся раскрывающиеся списки, меняющееся изображение витрины (выполнено в полном соответствии с Вашими рекомендациями), условное форматирование и подсказки "для защиты от дурака". Над размерными линиями надо проставить размеры из таблицы, но ячейки под рисунком не видны (рис.не прозрачный), а текстовое поле НЕ УДАЕТСЯ ПОВЕРХ НЕГО поставить. Почему? - не понимаю... (Ведь, если действовать через меню Вставить/Рисунок, то удается текстовое поле поставить поверх рисунка).
Прим.: В "ИД.Витрина..." управление раскрывающимися списками и условным форматированием осуществляется с скрытого листа.
Насчёт размера файла - проблему легко решить, обработав все ваши картинки специальной программой (которая в пакетном режиме обработает все изображения, уменьшив вес фотографий до 20-80кБ, - достаточно уменьшить размеры картинок или глубину цвета)
Выводить текст на листе Excel в текстбокс - зачем, когда для этого есть ячейки?
Но, если уж так нужен текстбокс, - и его сделать не проблема.
Попробовал - текстовое поле без проблем нарисовалось поверх картинки:
PS: Для подобных вопросов есть форумы по Excel
На этом сайте я обычно помогаю не бесплатно)
Поступил как указано в Ответе #26...
Мой файл при этом "потолстел" в 10 раз (с 506КБ, до 61000КБ).
Так не должно быть.
Прим.: вставляемая в Image2 картинка вести 3900КБ.
Действительно, "всё гениальное просто".
Спасибо!!! Стыдно, но деваться не куда, буду краснеть дальше....
Возникла еще одна проблемка:
Я хотел поверх Image1 (изменяющиеся изображения витрин в зависимости от выбранного в раскрывающ.списке) поместить меняющиеся надписи -габаритные размеры (TextBox), связав их с значениями в ячейках. Однако, не удается поместить эти TextBox над Imege1. Из меню под правой кнопкой мыши не удается выполнить ни "На передний план", ни "На задний план".
Как поступить?
Программирование - это, конечно, занятие творческое, но не до такой степени, чтобы выдумывать произвольные имена встроенным процедурам, и надеяться, что это всё заработает...
При изменении ячеек на листе сработает обработчик Worksheet_Change, а изобретенный вами Worksheet_Ch не сработает ни при каких обстоятельствах.
Замените эти 2 обработчика событий одним:
If Not Intersect(Target, [AE22:AE23]) Is Nothing Then ОбновлениеКартинкиВитрины
If Not Intersect(Target, [AE26]) Is Nothing Then ОбновлениеКартинкиСтоек
End Sub
Спасибо еще раз! Макрос и процедура работают замечательно!
Но... Захотелось по аналогии пристегнуть сменяющиеся картинки еще к одному раскрывающемуся списку и обломился. Не пойму почему. Подскажите - где ошибка?
Sub ОбновлениеКартинкиВитрины()
On Error Resume Next
Set [Image1].Object.Picture = Nothing
Set [Image1].Object.Picture = LoadPicture([Место_хранения_рисунка_витрины])
End Sub
Sub ОбновлениеКартинкиСтоек()
On Error Resume Next
Set [Image2].Object.Picture = Nothing
Set [Image2].Object.Picture = LoadPicture([Место_хранения_рисунка_стойки])
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [AE22:AE23]) Is Nothing Then ОбновлениеКартинкиВитрины
End Sub
Private Sub Worksheet_Ch(ByVal Target As Range)
If Not Intersect(Target, [AE26:AE26]) Is Nothing Then ОбновлениеКартинкиСтоек
End Sub
Макрос "Обновление картинки стоек" работает, но процедура, привязанная к изменению в ячейке AE26 не запускается. Почему?
СУППЕРРР!
Спасибо громадное!
Подскажите, где можно поучиться VBA для Exel в СПб?
Огромное С П А С И Б О!!!
Да неужели...
смотрите второй способ в этой статье:
http://www.planetaexcel.ru/tip.php?aid=34
вот ещё один способ:
http://www.planetaexcel.ru/tip.php?aid=70
..И тут же получу сообщение " Для условий "Проверка данных" нельзя использовать ссылки на другие листы"
Сделать это просто - присваиваете имя списку фирм, и в "данные\проверка\список..." указываете ссылку на именованный диапазон.
Как сделать ввод фирм в таблицу со списком, если список фирм расположен на другой странице?
(данные\проверка\список...)?
Макрос ОбновлениеКартинки - в стандартный модуль,
обработчик Worksheet_Change - в модуль листа.
Пример в файле: http://excelvba.ru/XL_Files/Sample__04-11-2011__13-22-08.zip
А как сделать, чтобы Процедура "Worksheet_Change" начала работать?
Куда и как её поместить?
Спасибо за оперативный ответ!
Попробую на выходных в домашних условиях.
Николай, всё делается проще, чем вы думаете.
Сначала вставляете в ячейку элемент управления Image:
а потом делаете макрос, изменяющий свойство Picture этого объекта:
On Error Resume Next
' удаляем старую картинку
Set [Image1].Object.Picture = Nothing
' добавляем новую
Set [Image1].Object.Picture = LoadPicture([d5])
End Sub
Осталось вызвать этот макрос при изменении ячейки С3 или C4:
If Not Intersect(Target, [c3:c4]) Is Nothing Then ОбновлениеКартинки
End Sub
Выше написанное Впечатляет, но для новичка…
На листе 30 раскрывающихся списков (Данные/проверка вводимых значений/список/...).
При изменении значений в ДВУХ списках (ячейка C3 и C4), в соседней ячейке (D5) изменяется путь к картинкам "\\Slim\fileupload\Витрины, прилавки\Рисунки\....jpg".
Надо МЕНЯТЬ картинки при изменении С3 или C4 (старая картинка должна удалятся, новая размещается на её место).
Картики надо вносить в ячейку A20 без изменения размеров ячейки и без изменения размеров картинки.
Макрос должен запускаться тоько при внесении изменений в C3 и/или С4 (при других действиях на листе макрос не должен запускается).
Подмогните, пожалуйста!
А я разве говорил, что копировать надо вручную?
С этим и макрос легко справится...
Вам подойдёт простейший макрос, который копирует первые строки всех файлов в итоговый файл
(в итоговый файл скопируется всё, вместе с картинками)
Скопировать ручками то понятно, я бы тогда у вас не спрашивал. :) Просто есть допустим 20-30 эксельных файлов, внутри которых на первом листе заполнены три столбца в первом ряду, т.е. три ячейки. В первых двух ячейках текст, а в третьей ячейке картинка. Задача в том, чтобы все эти 20-30 файлов (которые называются 1.xls, 2.xls, 3.xls и т.д.) превратить в один файл, у которого будут заполнены соответственно 20-30 первых строк.
А вы не пробовали просто скопировать ячейку с картинкой из одного файла в другой?
Это, пожалуй, самый простой способ.
Можно использовать также функцию getShape:
Dim sha As Shape
For Each sha In cell.Worksheet.Shapes
If sha.TopLeftCell.Address = cell.Address Then
Set getShape = sha: Exit Function
End If
Next sha
End Function
Sub КопированиеКартинки()
getShape([c1]).Copy [c2]
End Sub
Подскажите плиз, как из одного эксельного файла вставить картинку в другой эксельный файл?
Допустим картинка в первом файле находится в (или "над") ячейке C1 и эту картинку нужно вставить в ячейку C2, но уже в другой файл?
Мои Вам благодарности, разобрался со всем.
Ну почему же... макрорекордер записывает и вставку, и удаление картинки:
'
' Макрос2 Макрос
' Макрос записан 07.10.2011 (Игорь (EducatedFool))
'
ActiveSheet.Pictures.Insert("D:\Документы\Мои рисунки\123.jpg").Select
Selection.Delete
End Sub
Но этот макрос можно записать только в Excel 2003 (или более ранних версиях) и Excel 2010.
В Excel 2007 разработчики что-то намудрили с макрорекордером, и он очень много чего не записывает.
Так что проще всего вам будет установить (дополнительно) другую версию Excel - Excel 2007 в этом плане неудачен.
PS: Удалить картинку, зная её название, можно так:
Макрос - это, конечно, великолепно придумано, однако же, как Вам достоверно известно, если начать запись макроса и, выделив картинку, затем бесповортно удалить ее, то код макроса будет предательски пуст, ни единой строчки в теле функции... Как же быть? Не подскажите функцию по удалению из Книги конкретной картиночки, а?)
Вообще, удаление мне нужно это для того, чтобы динамически обновлять картинку при выборе одной из строк на другом листе (удалил - вставил на то самое мето). Это позволит не вставлять все файлы изображений сразу и соответственно разгрузить саму Книгу, храня изображения отдельно.
Не проще, ибо изображения должны быть на листе для последующей печати.
Да, можно так сделать. (пишете макрос, удаляющий картинки из файла при его закрытии)
Вот только зачем вставлять картинки в файл, если потом их удалять?
Не проще ли просто отобразить картинки на форме, без вставки в ячейки?
Любезнейший, ради всего святого, скажите можно ли сделать так, чтобы добавленная такой замечательнейшей функцией в определенную ячейку картинка, по завершении работы с Книгой автоматически удалялась?
То что дохтер прописал :)
Нижайшее МЕРСИ !!!
Для этого вам понадобится функция вывода диалогового окна выбора файла.
Ваш код будет выглядеть так:
' запрашиваем полный путь к файлу изображения
ПутьКФайлуСКартинками = GetFilePath("Выберите изображение", , "Изображения", "*.*")
' вставляем изображение в активную ячейку (картинка вписывается в ячейку)
ВставитьКартинку ActiveCell, ПутьКФайлуСКартинками, True, True, True
End Sub
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Книги Excel", _
Optional ByVal FilterExtention As String = "*.xls*") As String
' функция выводит диалоговое окно выбора файла с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
' для фильтра можно указать описание и расширение выбираемых файлов
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function
Прошу прощения за мой *французский*...
Но, если не известен точный путь файла картинки, и нужно найти его вручную.
Что нужно вписать вместо строки
ПутьКФайлуСКартинками = "D:\BMP\AboutForm.jpg"
чтоб выскакивало окошко для поиска (аналог кнопки *вставить картинку* на панели инструментов)?
Или может быть как-то можно закрепить эту кнопку на листе?
Здравствуйте, Игорь.
В случае вставки изображения с параметрами True, True, True (как мне кажется многие будут думать судя по комментариям в коде что картинка должна в этом случае остаться в пределах ячейки) подгонка картинки делается по высоте изображения (последнее действие), то есть по ширине может вылезать за пределы ячейки. Не буду приводить пример правильной подгонки ибо знаю что в Ваших макросах уже имеется правильный код. Думаю Вам имеет смысл поправить код на данной странице, чтобы наткнувшиеся на Ваш сайт люди не уходили с него в поисках более предсказуемых решений.
Спасибо за Ваши работы, парочку из них уже использовал в работе, значительно упростив код.
С уважением, Виталий
Отправить комментарий