mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Макрос для увеличения картинок по щелчку мыши

Макрос позволяет увеличивать / уменьшать изображения на листе 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

ВложениеРазмерЗагрузкиПоследняя загрузка
ZoomPictures.xls102.5 КБ4618 недель 4 дня назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Координаты вычисляются в переменных 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 ("квадратный" монитор) открыли: картинки кликаются, но увеличиваются только по ширине, а высота остается той же. т.е. получается как бы растягиваются.
Может исправить что то?

Большое спасибо!!!! Все получилось.

Запустите такой макрос:

Sub ПереименованиеКартинок()
    On Error Resume Next: Dim sha As Shape, n&
    For Each sha In ActiveSheet.Shapes
        n = n + 1: sha.Name = "image_" & n
    Next
End Sub

После этого, все картинки на листе получат уникальные имена вида image_1, image_2, и т.д.

Как изменить имя картинки ? Вот, что получается в папке название фото одно (IMG_254) при вставке в Excel название меняется на (рисунок 2), а в таблице уже есть фото под названием (рисунок 2) и получается, что при увеличении фото показывается самое первое загруженное фото. Как это исправить. В папке менял название даже на буквы не помогает.

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

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

Спасибо макрос работает!!! только у меня проблема некоторые фотографии при Увеличении показывает другое фото. Как решить данную проблему, чтобы увеличивалась та картинка по которой кликнул.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _      _       __   ____    ____        _ 
| | __ | | __ / _| / ___| | _ \ __| |
| |/ / | |/ / | |_ \___ \ | | | | / _` |
| < | < | _| ___) | | |_| | | (_| |
|_|\_\ |_|\_\ |_| |____/ |____/ \__,_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

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