Sub ZoomImage()
Const ZOOM_RATIO# = 3
Const STEPS_COUNT& = 20
Const ZOOM_SPEED# = 2
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 / 3: cy1# = .Top + .Height / 4
dw# = .Width / STEPS_COUNT&
dt# = ZOOM_SPEED# / 50 / STEPS_COUNT&
For i& = 1 To STEPS_COUNT&
t = Timer: .Width = .Width - dw#
.Left = cx1# - .Width / 3: .Top = cy1# - .Height / 3
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
