Макрос позволяет увеличивать / уменьшать изображения на листе Excel по щелчку мыши.
Для использования макроса, скопируйте в свой файл модуль с кодом (просто перетащив его мышкой из прикреплённого файла),
выделите все картинки в своём файле Excel, и назначьте им макрос ZoomImage
Чтобы выделить все изображения, проделайте следующее:
- нажмите Ctrl + G (для появления диалогового окна «Переход»)
- нажмите кнопку «Выделить» в этом диалогом окне
- в появившемся окне «Выделение группы ячеек» поставьте галочку «Объекты», и нажмите OK
После этого (как все картинки будут выделены), щелкните на одной из картинок правой кнопкой мыши,
в контекстном меню нажмите «Назначить макрос», выделите макрос ZoomImage, и нажмите OK
При щелчке на картинке, макрос плавно увеличивает картинку в 3 раза, попутно перемещая её в центр экрана
(коэффициент увеличения, скорость увеличения фото, и количество промежуточных шагов увеличения, можно задать в коде)
Для увеличения создаётся копия исходной картинки.
При щелчке на увеличенной картинке, она плавно уменьшается в размерах, после чего удаляется.
Код макроса ZoomImage:
Sub ZoomImage() ' Макрос для увеличения / уменьшения картинок в Excel, по щелчку на них ' © 2013 EducatedFool ExcelVBA.ru/code/ZoomImages Const ZOOM_RATIO# = 3 ' коэффициент увеличения изображения Const STEPS_COUNT& = 20 ' количество промежуточных шагов при увеличении Const ZOOM_SPEED# = 2 ' скорость увеличения / уменьшения картинки ( от 0 до 10) On Error Resume Next: Err.Clear: Dim sha As Shape, s_sha As Shape, i& Set s_sha = ActiveSheet.Shapes(Application.Caller) If Err Then Exit Sub ' выход, если макрос вызван не щелчком на картинке If s_sha.Name Like "BigImage_*" Then ' щелчок на увеличенной картинке With s_sha cx1# = .Left + .Width / 2: cy1# = .Top + .Height / 2 dw# = .Width / STEPS_COUNT& dt# = ZOOM_SPEED# / 50 / STEPS_COUNT& For i& = 1 To STEPS_COUNT& ' в цикле уменьшаем картинку t = Timer: .Width = .Width - dw# .Left = cx1# - .Width / 2: .Top = cy1# - .Height / 2 While Timer - t < dt#: DoEvents: Wend Next i .Delete ' а потом удаляем её End With Else ' щелчок на исходной картинке, - создаём её копию, и увеличиваем For Each sha In ActiveSheet.Shapes If sha.Name Like "BigImage_*" Then sha.Delete Next Set sha = s_sha.Duplicate ' создаем копию картинки sha.Top = s_sha.Top: sha.Left = s_sha.Left ' помещаем копию поверх исходной sha.Name = "BigImage_" & Timer ' переименовываем изображение sha.LockAspectRatio = 1 ' если есть закреплённые столбцы и строки TopRowsHeight# = Range("1:1").RowHeight ' закреплена первая строка LeftColumnsWidth# = 0 ' закреплённых столбцов нет With sha cx1# = .Left + .Width / 2: cy1# = .Top + .Height / 2 cx2# = Columns(ActiveWindow.ScrollColumn).Left - LeftColumnsWidth# + _ ActiveWindow.Width / 2 * 100 / ActiveWindow.Zoom cy2# = Rows(ActiveWindow.ScrollRow).Top - TopRowsHeight# + _ ActiveWindow.Height / 2 * 100 / ActiveWindow.Zoom dw# = .Width * (ZOOM_RATIO# - 1) / STEPS_COUNT& dx# = (cx2# - cx1#) / STEPS_COUNT&: dy# = (cy2# - cy1#) / STEPS_COUNT& cx# = cx1#: cy# = cy1#: dt# = ZOOM_SPEED# / 50 / STEPS_COUNT& For i& = 1 To STEPS_COUNT& t = Timer: cx# = cx# + dx#: cy# = cy# + dy# .Width = .Width + dw#: .Left = cx# - .Width / 2: .Top = cy# - .Height / 2 While Timer - t < dt#: DoEvents: Wend Next i End With End If End Sub
Комментарии
Николай, макрос тут ни при чём.
Если картинки торчат при фильтрации, значит, вы им свойства неверно задали.
При снятом фильтре нужно сделать это: https://excelvba.ru/programmes/PastePictures/manuals/errors/filter
Спасибо за работу.
Не смог понять как применить этот шикарный вариант для фильтрации строк срезами? стандартный фильт по выделенному диапазону вроде частично работает, но по факту картинки (на 10-15% размера их края) торчат эдакой колодой карт под выделенной строкой из фильтруемых...
Есть вариант чтобы этот макрос позволял прокликивать картинки и скрывать и сортировать их вместе с фильтром? (Пусть по тексту в соседних ячейках, но чтобы работало.)
Макрос работает, НО почему то при нажатии на картинку открывает только самую первую в столбце. при нажатии на любые другие картинки открывает только самую первую.В чем может быть причина?
Спасибо! Очень пригодилось!
Добрый день Игорь ,
могу заказать вам небольшую работу ?
Я вам сброшу свой файл в EXEL ( это каталог моих товаров) .
Добавьте ваш макрос для увеличения изображений .
Так как каталог меняется при поступлении или убытии товаров , нужна ваша инструкция по изменениям6 которые потребуются .
Сообщите цену вопроса .
сколько это будет стоить ?
ОГРОМНОЕ спасибо!
Макрос прекрасно работает и гибко настраивается (в умеренных пределах). Excel 2010
Спасибо Игорь. не подскажите как можно ли сделать так чтоб изображение не только увеличивалось но и поворачивалось по нажатию.
Это надо заметно усложнять макрос.
А как сделать чтобы картинка в конце уплывала на своё место? а то когда увеличивается то то постепенно это делает со своего места, а когда уменьшается то делает это посередине экрана
Нет, макросы работают только в Excel. В ПДФ работать не будет
Игорь, добрый день!
Подскажите, будет ли работать этот функционал (увеличение фото по клику), если сохранить документ Exel в PDF или XPS?
Хотим в прайс добавить картинки, но прайс отправляем клиентам не в экселе, чтоб слуйчайно не редактировалось ничего.
Буду благодарен за ответ!
Мои макросы гарантированно работают только под windows. На маке - там многое по-другому делается.
Макрос не работает для MAC
Доброго времени суток пожалуйста помогите, использовал макрос, часть картинок увеличивает, а некоторые при нажатие на нее увеличивают картинку с другой строки.
Координаты вычисляются в переменных cx2# и cу2# — исправьте код, чтобы там были нужные вам значения координат.
Если сами не разберетесь, могу сделать под заказ (платно)
а как задать координаты увеличенной картики, что бы не по центру экрана выходил а справа снизу
После сохранения портится качество картинки до нечитаемого, что делать? Excel 2010
Причина в том, что Excel автоматически сжимает рисунки при сохранении. Чтобы этого избежать надо зайти: Файл -> Параметры -> Дополнительно и поставить галочку в пункте "Не сжимать изображения в файле". В зависимости от версии Excel данная функция может быть в другом разделе.
Добрый день.
А как дописать код таким образом что бы вместе с увеличением картинки менялся цвет границы данной картинки
Это не от макроса зависит, а от того, в каком размере и с каким качеством вставлены картинки.
Если вставить картинку размером 40*50 пикселей, - конечно, она при увеличении до размеров 400*500 будет выглядеть ужасно.
А если вы вставите на лист фотографию размером 3000*2000, а потом уменьшите её до 30*20, - то при щелчке она будет увеличиваться без всякой потери качества (так как на листе она хоть и отображается маленькой, - Excel её хранит целиком).
Но, опять же, если в случае с этим большим фото, в Excel нажать кнопку СЖАТЬ ИЗОБРАЖЕНИЯ, - после сохранения файла и повторного его открытия, Excel обрежет ненужное, - и картинка 3000*2000 превратится в картинку 30*20 - и тогда увеличение опять даст плохой результат.
А чтобы и файл Excel много не весил, и картинки при увеличении сильно качество не теряли, - размеры вставляемых картинок должны быть порядка 200-500 пикселей (при этом, не имеет значения, на сколько они уменьшены в размерах при вставке на лист)
Добрый день!!! проблема в том что после того как кликаешь по картинке при увеличение теряется качество картинки. как это можно исправить. побывал разные размеры картины не помогло.
Добрый день!
Спасибо за Вашу работу, однако при использовании возникли проблемы. После сохранения файла и повторноv его открытиb качество увеличенной картинки ухудшается. В чем причина?
здравствуйте, все отлично внедрил в свой файл.
Но Закрыв все, и удалив файл ZoomPictures.xls
Я открыл вновь свой файл, и увеличение перестало работать, просит найти путь к файлу ZoomPictures.xls.
Подскажите пожалуйста как решить эту проблему, ведь когда я перенесу свой файл на другой комп, там априори не будет зуум файла.
Антонина, по ценам здесь написано.
Если нет четкого техзадания, - я даже примерно цену не могу сказать.
ОГРОМНОЕ СПАСИБО!!! ЕЩЕ ВОПРОС, ВОЗМОЖНО НЕ ПО ТЕМЕ. СКОЛЬКО БУДЕТ СТОИТЬ НАПИСАНИЕ ПРОГРАММЫ ДЛЯ ФОРМИРОВАНИЯ ПРАЙС ЛИСТОВ ДЛЯ КЛИЕНТОВ.
Здравствуйте, Антонина.
Этот макрос не увеличивает размер файла Excel, - всё дело в картинках.
Чтобы файл с картинками весил немного, - используйте для вставки изображений эту программу:
http://excelvba.ru/programmes/PastePictures
со включенной опцией сжатия картинок (тогда картинки будут вставляться уменьшенными - это позволит достичь минимального размера файла Excel)
У меня вопрос, а можно, как-нибудь уменьшить размер всего файла xls, а то с этим макросом он начал весить очень много. Или может картинок очень много. В общем как решить задачу: формирование прайс-листа с изображениями, но небольшого по весу. Спасибо за любой ответ.
Огромное спасибо!!!
Все здорово работает!!!
Здравствуйте, Алексей
Надо назначить макрос скрытия картинки (не тот, что в статье приведен, - а немного другой сделать) для клавиши ESC (это делается через метод Application.OnKey), и тот же макрос вызывать при событии листа SelectionChange (которое срабатывает при выделении ячейки, - но по ячейке надо щелкнуть не по той которая была выделена до этого, - а по любой другой)
Если сами не разберетесь, как все это сделать, - оформляйте заказ, сделаю под ваши требования.
Добрый день.
Спасибо за макрос. Работает без проблем.
А не подскажите, как сделать чтобы картинка уменьшалась не только по щелчку на картинке, но и по нажатию "Esc" и по щелчку на любом пустом месте на листе.
Здравствуйте, Алексей.
Вряд ли чем смогу помочь, - у меня в любой версии Excel проблем с этим кодом не наблюдается
(проверял на прикреплённом к статье файле)
А поскольку проблема на моём компе не проявляется, - очень сложно найти причину такого поведения макроса.
(даже предположений нет)
Вы проверяли на своём файле, или на тестовом из этой статьи?
У меня все работает в 2007 (широкоформатный экран). Этот же файл в 2003 ("квадратный" монитор) открыли: картинки кликаются, но увеличиваются только по ширине, а высота остается той же. т.е. получается как бы растягиваются.
Может исправить что то?
Большое спасибо!!!! Все получилось.
Запустите такой макрос:
После этого, все картинки на листе получат уникальные имена вида image_1, image_2, и т.д.
Как изменить имя картинки ? Вот, что получается в папке название фото одно (IMG_254) при вставке в Excel название меняется на (рисунок 2), а в таблице уже есть фото под названием (рисунок 2) и получается, что при увеличении фото показывается самое первое загруженное фото. Как это исправить. В папке менял название даже на буквы не помогает.
Здравствуйте, Иван.
Я с подобным поведением не сталкивался.
Макрос запоминает название картинки, по которой щелкнули, и эту картинку потом находит на листе, и увеличивает.
Если вдруг на листе окажется несколько картинок с одинаковым именем (хотя, вроде бы, это невозможно), - то макрос может увеличивать другую картинку с тем же именем.
Имя картинки отображается слева от строки формул, при выделении изображения (чтобы выделить картинку. которой назначен макрос, удерживайте клавишу Ctrl)
Спасибо макрос работает!!! только у меня проблема некоторые фотографии при Увеличении показывает другое фото. Как решить данную проблему, чтобы увеличивалась та картинка по которой кликнул.
Отправить комментарий