Class for Zooming on images (Picture Shapes) displayed on worksheets.

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,779
Office Version
  1. 2016
Platform
  1. 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.



Thumbnail-PreviewsY.gif





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 Function



2- 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
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Wow!!

This is amazing.

I am thinking of something cool to do with this. Thanks
 
Upvote 0
kelly mort said:
Wow!!

This is amazing.

I am thinking of something cool to do with this. Thanks
Click to expand...

Hi Kelly,

Glad you liked it and thanks for the feedback.

The code should be easily adaptable for specific requirements.

Regards.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question Question
KeyPress Event for Worksheet Cells (Subclassing Without Crashing)
Replies
0
Views
156
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question Question
Capturing the Paste Event (API Hooking - Redirection)
Replies
4
Views
745
Jaafar Tribak
Jaafar Tribak
D
  • Solved
Long vs Longptr
Replies
7
Views
317
Micron
M
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
300
Minh Tuan VN
M
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
742
huiettcm
H

Forum statistics

Threads
1,223,162
Messages
6,170,431
Members
452,326
Latest member
johnshaji

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top