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

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