Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
I thought I would post here this vba code, which as the title says , it allows zooming In\Out on worksheet images.
I was prompted to write the code by a question asked recently here :https://www.mrexcel.com/forum/excel-questions/1110968-zoom-image-picture-displayed-workbook.html
The Class code also permits zooming via the mouse scroll button (while holding down the CTRL key)
Here is a workbook example that illustrates how this works.
I hope you find this useful.
1- Class Code : ( C_PicZoom )
2- Code Usage example: ( Sheet1 Code Module )
I thought I would post here this vba code, which as the title says , it allows zooming In\Out on worksheet images.
I was prompted to write the code by a question asked recently here :https://www.mrexcel.com/forum/excel-questions/1110968-zoom-image-picture-displayed-workbook.html
The Class code also permits zooming via the mouse scroll button (while holding down the CTRL key)
Here is a workbook example that illustrates how this works.
I hope you find this useful.
1- Class Code : ( C_PicZoom )
Code:
Option Explicit
Public Enum ZoomDirection
Center
TopLeft
TopRight
BottomLeft
BottomRight
lLeft
lTop
lRight
lBottom
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
Private Type MSG
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] Win64 Then
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function WaitMessage Lib "user32" () As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private WithEvents CmndBars As CommandBars
Private bEnable As Boolean, bMouseScroll As Boolean, bZoomingOut As Boolean
Private initPicWidth As Long, initPicHeight As Long
Private lZoomFac As Variant, oThisPic As Object, oZoomCell As Range
Public Property Let EnablePicZooming(ByVal Pic As Object, Optional ByVal ZoomFac As Variant = 10, Optional ByVal ZoomCell As Range, ByVal Enable As Boolean)
If GetProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive") = -1 Then
Call UnregisterHotKey(Application.hwnd, &HBFFF&)
Call RemoveProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive")
End If
With Pic.PictureFormat.Crop
If Val(ZoomFac) <> ZoomFac Then ZoomFac = 10
If Val(ZoomFac) <= 0 Then ZoomFac = 10
If Val(ZoomFac) >= 50 Then ZoomFac = 80
lZoomFac = ZoomFac
If TypeName(Pic) = "Shape" Then
Set oThisPic = Pic
initPicWidth = .ShapeWidth
initPicHeight = .ShapeHeight
If Enable Then
bEnable = True
If Not ZoomCell Is Nothing Then
Set oZoomCell = ZoomCell
ZoomCell.Value = 0
End If
Else
bEnable = False
oThisPic.AlternativeText = ""
Call ResetPic(oZoomCell)
Set CmndBars = Nothing
End If
End If
End With
End Property
Public Property Get EnablePicZooming(ByVal Pic As Object, Optional ByVal ZoomFac As Variant = 10, Optional ByVal ZoomCell As Range) As Boolean
EnablePicZooming = bEnable
End Property
Public Property Let EnableMouseScrollZoom(ByVal Enable As Boolean)
Const MOD_CONTROL = &H2
bMouseScroll = Enable
If oThisPic Is Nothing Then Exit Property
If Enable Then
If GetProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive") = -1 Then
Call RemoveProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive")
End If
Call RegisterHotKey(Application.hwnd, &HBFFF&, MOD_CONTROL, VBA.vbKeyControl)
Call SetProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive", _
GetProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive") + 1)
oThisPic.AlternativeText = oThisPic.Name
Set CmndBars = Nothing
Set CmndBars = Application.CommandBars
Call CmndBars_OnUpdate
Else
oThisPic.AlternativeText = ""
Call SetProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive", GetProp(Application.hwnd, _
"NumberOfPicsWithMouseScrollActive") - 1)
If GetProp(Application.hwnd, "NumberOfPicsWithMouseScrollActive") = 0 Then
Call UnregisterHotKey(Application.hwnd, &HBFFF&)
End If
Set CmndBars = Nothing
End If
End Property
Public Property Get EnableMouseScrollZoom() As Boolean
EnableMouseScrollZoom = bMouseScroll
End Property
Public Property Get CurZoom() As Variant
Dim initZoom As Variant
initZoom = Int(initPicWidth * initPicHeight)
With oThisPic.PictureFormat.Crop
CurZoom = Int(100 * ((.PictureWidth * .PictureHeight) - initZoom) / initZoom) & "%"
End With
End Property
Public Property Get ZoomFactor() As Variant
ZoomFactor = lZoomFac
End Property
Public Sub ZoomIn(ByVal ZoomDirc As ZoomDirection)
If bEnable = False Then Exit Sub
With oThisPic.PictureFormat.Crop
oThisPic.LockAspectRatio = msoFalse
Select Case ZoomDirc
Case 0 'Center
Case 1 'topLeft
.PictureOffsetX = .PictureOffsetX + lZoomFac
.PictureOffsetY = .PictureOffsetY + lZoomFac
Case 2 'TopRight
.PictureOffsetX = .PictureOffsetX - lZoomFac
.PictureOffsetY = .PictureOffsetY + lZoomFac
Case 3 'BottomLeft
.PictureOffsetX = .PictureOffsetX + lZoomFac
.PictureOffsetY = .PictureOffsetY - lZoomFac
Case 4 'BottomRight
.PictureOffsetX = .PictureOffsetX - lZoomFac
.PictureOffsetY = .PictureOffsetY - lZoomFac
Case 5 'Left
.PictureOffsetX = .PictureOffsetX + lZoomFac
Case 6 'Top
.PictureOffsetY = .PictureOffsetY + lZoomFac
Case 7 'Right
.PictureOffsetX = .PictureOffsetX - lZoomFac
Case 8 'Bottom
.PictureOffsetY = .PictureOffsetY - lZoomFac
End Select
.PictureHeight = .PictureHeight + lZoomFac * 2
.PictureWidth = .PictureWidth + lZoomFac * 2
End With
If Not oZoomCell Is Nothing Then
oZoomCell.Value = CurZoom
End If
End Sub
Public Sub ZoomOut()
If bEnable = False Then Exit Sub
With oThisPic.PictureFormat.Crop
.PictureHeight = .PictureHeight - (lZoomFac * 2)
If Int(.PictureHeight) < Int(initPicHeight) Then
bZoomingOut = True
Call ResetPic
bZoomingOut = False
Exit Sub
End If
.PictureWidth = .PictureWidth - (lZoomFac * 2)
If Int(.PictureWidth) < Int(initPicWidth) Then
bZoomingOut = True
Call ResetPic
bZoomingOut = False
Exit Sub
End If
If (.PictureOffsetY) > 0 Then .PictureOffsetY = .PictureOffsetY - lZoomFac
If (.PictureOffsetY) < 0 Then .PictureOffsetY = .PictureOffsetY + lZoomFac
If (.PictureOffsetX) > 0 Then .PictureOffsetX = .PictureOffsetX - lZoomFac
If (.PictureOffsetX) < 0 Then .PictureOffsetX = .PictureOffsetX + lZoomFac
End With
If Not oZoomCell Is Nothing Then
oZoomCell.Value = CurZoom
End If
End Sub
Public Sub ResetPic(Optional CurrentZoomInCell As Range)
If Not oThisPic Is Nothing Then
With oThisPic.PictureFormat.Crop
.PictureWidth = .ShapeWidth
.PictureHeight = .ShapeHeight
.PictureOffsetX = 0
.PictureOffsetY = 0
End With
End If
If Not oZoomCell Is Nothing Then
If bZoomingOut Then
oZoomCell.Value = 0
Else
oZoomCell.ClearContents
End If
End If
End Sub
Private Sub CmndBars_OnUpdate() 'MouseScrollZooming
Const WM_MOUSEWHEEL = &H20A
Const PM_REMOVE = &H1
Const MK_CONTROL = &H8
Dim tMsg As MSG, tCurPos As POINTAPI
Dim tRectCenter As RECT, tRectTopLeft As RECT, tRectTopRight As RECT
Dim tRectBottomLeft As RECT, tRectBottomRight As RECT, tRectArray(5) As RECT
Dim oCurrentObjUnderMouse As Object
Dim eDir As ZoomDirection, i As Long
On Error GoTo errHandler:
If bMouseScroll = False Then Exit Sub
With Application.CommandBars.FindControl(id:=2040)
.Enabled = Not .Enabled
End With
Call GetCursorPos(tCurPos)
Set oCurrentObjUnderMouse = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)
If TypeName(oCurrentObjUnderMouse) = "Picture" Then
oThisPic.Parent.ScrollArea = ActiveWindow.VisibleRange.Address
Do
If GetForegroundWindow = FindWindow("wndclass_desked_gsk", vbNullString) Then
Call UnregisterHotKey(Application.hwnd, &HBFFF&)
Call ResetPic(oZoomCell)
MsgBox "Activating the VBE while the MouseScroll is set resets the vbproject !!!" _
& vbNewLine & vbNewLine & "Disable the Pic(s) Zooming and restart Again.", vbExclamation
End
End If
Call GetCursorPos(tCurPos)
Set oCurrentObjUnderMouse = ActiveWindow.RangeFromPoint(tCurPos.X, tCurPos.Y)
If TypeName(oCurrentObjUnderMouse) = "Range" Or TypeName(oCurrentObjUnderMouse) = "Nothing" Then
Exit Do
End If
If Len(oThisPic.AlternativeText) Then
If bMouseScroll Then
Call WaitMessage
If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
If oCurrentObjUnderMouse.Name <> oThisPic.Name Then
Exit Sub
End If
tRectCenter = ObjRect(oCurrentObjUnderMouse, Center)
tRectTopLeft = ObjRect(oCurrentObjUnderMouse, TopLeft)
tRectTopRight = ObjRect(oCurrentObjUnderMouse, TopRight)
tRectBottomLeft = ObjRect(oCurrentObjUnderMouse, BottomLeft)
tRectBottomRight = ObjRect(oCurrentObjUnderMouse, BottomRight)
tRectArray(0) = tRectCenter
tRectArray(1) = tRectTopLeft
tRectArray(2) = tRectTopRight
tRectArray(3) = tRectBottomLeft
tRectArray(4) = tRectBottomRight
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] Win64 And VBA7 Then
Dim lPt As LongPtr
Call CopyMemory(lPt, tCurPos, LenB(tCurPos))
For i = 0 To 8
If PtInRect(tRectArray(i), lPt) = 1 Then Exit For
Next
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
For i = 0 To 8
If PtInRect(tRectArray(i), tCurPos.X, tCurPos.Y) = 1 Then Exit For
Next
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Select Case i
Case Is = 0
eDir = Center
Case Is = 1
eDir = TopLeft
Case Is = 2
eDir = TopRight
Case Is = 3
eDir = BottomLeft
Case Is = 4
eDir = BottomRight
Case Is = 5
eDir = lLeft
Case Is = 6
eDir = lTop
Case Is = 7
eDir = lRight
Case Is = 8
eDir = lBottom
End Select
If GetAsyncKeyState(VBA.vbKeyControl) Then
If tMsg.wParam \ 120 = 65536 Then
Call ZoomIn(eDir)
Else
Call ZoomOut
End If
If Not oZoomCell Is Nothing Then
DoEvents: oZoomCell = CurZoom: DoEvents
End If
End If
End If 'PeekMessage
End If
End If
DoEvents
Loop
End If
oThisPic.Parent.ScrollArea = ""
Exit Sub
errHandler:
Call UnregisterHotKey(Application.hwnd, &HBFFF&)
oThisPic.Parent.ScrollArea = ""
Call ResetPic(oZoomCell)
End Sub
Private Function ObjRect(ByVal Obj As Object, ByVal dirc As ZoomDirection) As RECT
Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
Dim oPane As Pane
Set oPane = ThisWorkbook.Windows(1).ActivePane
With Obj
Select Case dirc
Case Is = 0 'Center
lLeft = .Left + (.Width) / 3
lTop = .Top + (.Height) / 3
lWidth = .Width - (.Width) * (2 / 3)
lHeight = .Height - (.Height) * (2 / 3)
Case Is = 1 'Topleft
lLeft = .Left
lTop = .Top
lWidth = .Width / 2
lHeight = .Height / 2
Case Is = 2 'TopRight
lLeft = .Left + (.Width / 2)
lTop = .Top
lWidth = .Width / 2
lHeight = .Height / 2
Case Is = 3 'BottomLeft
lLeft = .Left
lTop = .Top + .Height / 2
lWidth = .Width / 2
lHeight = .Height / 2
Case Is = 4 'BottomRight
lLeft = .Left + (.Width / 2)
lTop = .Top + (.Height / 2)
lWidth = .Width / 2
lHeight = .Height / 2
End Select
End With
With ObjRect
.Left = oPane.PointsToScreenPixelsX(lLeft - 1)
.Top = oPane.PointsToScreenPixelsY(lTop - 1)
.Right = oPane.PointsToScreenPixelsX(lLeft + lWidth)
.Bottom = oPane.PointsToScreenPixelsY(lTop + lHeight + 1)
End With
End Function
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
Const POINTSPERINCH = 72
PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function2- Code Usage example: ( Sheet1 Code Module )
Code:
Option Explicit
Private WithEvents wb As Workbook
Private Pic1 As New C_PicZoom
Private Pic2 As New C_PicZoom
'Pic1
'=======
Private Sub ChkboxEnablePic1_Change()
Set wb = ThisWorkbook
Pic1.EnablePicZooming(Me.Shapes("Picture 1"), TextBoxPic1.Value, Sheet1.Range("G17")) = CBool(ChkboxEnablePic1.Value)
If CBool(ChkboxEnablePic1.Value) = False Then
CheckBoxMouseScrollPic1.Value = 0
TextBoxPic1.Value = ""
Else
If TextBoxPic1.Value = "" Then TextBoxPic1.Value = 10
End If
End Sub
Private Sub CheckBoxMouseScrollPic1_Change()
Pic1.EnableMouseScrollZoom = CBool(CheckBoxMouseScrollPic1.Value)
End Sub
Private Sub TextBoxPic1_Change()
If Pic1.EnablePicZooming(Me.Shapes("Picture 1"), TextBoxPic1.Value) Then
Pic1.EnablePicZooming(Me.Shapes("Picture 1"), TextBoxPic1.Value) = True
End If
End Sub
Private Sub SpinButtonPic1_SpinUp()
Call ZoomIn(Pic1, Center)
End Sub
Private Sub SpinButtonPic1_SpinDown()
Call ZoomOut(Pic1)
End Sub
Private Sub btn_ResetPic1_Click()
Call Pic1.ResetPic
End Sub
Public Sub ZoomInCenter1()
Call Pic1.ZoomIn(Center)
End Sub
Public Sub ZoomInLeft1()
Call Pic1.ZoomIn(lLeft)
End Sub
Public Sub ZoomInTop1()
Call Pic1.ZoomIn(lTop)
End Sub
Public Sub ZoomInRight1()
Call Pic1.ZoomIn(lRight)
End Sub
Public Sub ZoomInBottom1()
Call Pic1.ZoomIn(lBottom)
End Sub
Public Sub ZoomInTopLeft1()
Call Pic1.ZoomIn(TopLeft)
End Sub
Public Sub ZoomInTopRight1()
Call Pic1.ZoomIn(TopRight)
End Sub
Public Sub ZoomInBottomLeft1()
Call Pic1.ZoomIn(BottomLeft)
End Sub
Public Sub ZoomInBottomRight1()
Call Pic1.ZoomIn(BottomRight)
End Sub
'Pic2
'==========
Private Sub ChkboxEnablePic2_Change()
Set wb = ThisWorkbook
Pic2.EnablePicZooming(Me.Shapes("Picture 2"), TextBoxPic2.Value, Sheet1.Range("P17")) = CBool(ChkboxEnablePic2.Value)
If CBool(ChkboxEnablePic2.Value) = False Then
CheckBoxMouseScrollPic2.Value = 0
TextBoxPic2.Value = ""
Else
If TextBoxPic2.Value = "" Then TextBoxPic2.Value = 10
End If
End Sub
Private Sub CheckBoxMouseScrollPic2_Change()
Pic2.EnableMouseScrollZoom = CBool(CheckBoxMouseScrollPic2.Value)
End Sub
Private Sub TextBoxPic2_Change()
If Pic2.EnablePicZooming(Me.Shapes("Picture 2"), TextBoxPic2.Value) Then
Pic2.EnablePicZooming(Me.Shapes("Picture 2"), TextBoxPic2.Value) = True
End If
End Sub
Private Sub SpinButtonPic2_SpinUp()
Call ZoomIn(Pic2, Center)
End Sub
Private Sub SpinButtonPic2_SpinDown()
Call ZoomOut(Pic2)
End Sub
Private Sub btn_ResetPic2_Click()
Call Pic2.ResetPic
End Sub
Public Sub ZoomInCenter2()
Call Pic2.ZoomIn(Center)
End Sub
Public Sub ZoomInLeft2()
Call Pic2.ZoomIn(lLeft)
End Sub
Public Sub ZoomInTop2()
Call Pic2.ZoomIn(lTop)
End Sub
Public Sub ZoomInRight2()
Call Pic2.ZoomIn(lRight)
End Sub
Public Sub ZoomInBottom2()
Call Pic2.ZoomIn(lBottom)
End Sub
Public Sub ZoomInTopLeft2()
Call Pic2.ZoomIn(TopLeft)
End Sub
Public Sub ZoomInTopRight2()
Call Pic2.ZoomIn(TopRight)
End Sub
Public Sub ZoomInBottomLeft2()
Call Pic2.ZoomIn(BottomLeft)
End Sub
Public Sub ZoomInBottomRight2()
Call Pic2.ZoomIn(BottomRight)
End Sub
'Shared code
'============
Private Sub ZoomIn(ByVal Obj As Object, ByVal ZoomDirc As ZoomDirection)
If Pic1.EnablePicZooming(Me.Shapes("Picture 1")) Then
If TextBoxPic1.Value <= 0 Then TextBoxPic1.Value = 10
If TextBoxPic1.Value >= 50 Then TextBoxPic1.Value = 80
End If
If Pic2.EnablePicZooming(Me.Shapes("Picture 2")) Then
If TextBoxPic2.Value <= 0 Then TextBoxPic2.Value = 10
If TextBoxPic2.Value >= 50 Then TextBoxPic2.Value = 80
End If
Call Obj.ZoomIn(ZoomDirc)
End Sub
Private Sub ZoomOut(ByVal Obj As Object)
If Pic1.EnablePicZooming(Me.Shapes("Picture 1")) Then
If TextBoxPic1.Value <= 0 Then TextBoxPic1.Value = 10
If TextBoxPic1.Value >= 50 Then TextBoxPic1.Value = 80
End If
If Pic2.EnablePicZooming(Me.Shapes("Picture 2")) Then
If TextBoxPic2.Value <= 0 Then TextBoxPic2.Value = 10
If TextBoxPic2.Value >= 50 Then TextBoxPic2.Value = 80
End If
Call Obj.ZoomOut
End Sub
'
Private Sub wb_BeforeClose(Cancel As Boolean)
Call Pic1.ResetPic
Call Pic2.ResetPic
TextBoxPic1.Value = ""
TextBoxPic2.Value = ""
ChkboxEnablePic1.Value = 0
ChkboxEnablePic2.Value = 0
CheckBoxMouseScrollPic1.Value = 0
CheckBoxMouseScrollPic2.Value = 0
Set Pic1 = Nothing
Set Pic2 = Nothing
End Sub
