'Reminder: Working version possibly with TODO, DEBUG etc. Use for further development.

Imports System.ComponentModel

<ToolboxBitmap("ZoomPictureBox.bmp")>
Public Class ZoomPictureBox_Jan2022
    Inherits System.Windows.Forms.UserControl

#Region "Constructor"

    Public Sub New()
        Me.DoubleBuffered = True
        Me.BackColor = Color.FromKnownColor(KnownColor.AppWorkspace)
        Me.Size = New Size(200, 200)
    End Sub

#End Region

#Region "Public properties"

    <Category("_ZoomPictureBox"), DefaultValue(50),
       Description("Safety margin to prevent the image moving ""off-screen"" during dragging or zooming. Set to 0 to allow off-screen.")>
    Public Property SafeMargin As Integer
        Get
            Return _SafeMargin
        End Get
        Set(value As Integer)
            If value >= 0 Then _SafeMargin = value
        End Set
    End Property

    <Category("_ZoomPictureBox"),
    Description("Enables image dragging with the left mouse button. Set to False if you implement other means of image scrolling.")>
    Public Property EnableMouseDragging As Boolean
        Get
            Return _EnableMouseWheelDragging
        End Get
        Set(value As Boolean)
            _EnableMouseWheelDragging = value
        End Set
    End Property

    <Category("_ZoomPictureBox"),
     Description("Enables mouse wheel zooming. Set to false e.g. if you control zooming with a TrackBar.")>
    Public Property EnableMouseWheelZooming As Boolean
        Get
            Return _EnableMouseWheelZooming
        End Get
        Set(value As Boolean)
            _EnableMouseWheelZooming = value
        End Set
    End Property

    <Category("_ZoomPictureBox"),
    Description("Image to display in the ZoomPictureBox."),
    DefaultValue(GetType(Image), Nothing)>
    Public Property Image() As Image
        Get
            Return _Image
        End Get
        Set(ByVal value As Image)
            _Image = value
            If value Is Nothing Then
                Me.ImageBounds = Rectangle.Empty
                Me.Refresh()
            Else
                Dim oldBounds As RectangleF = _ImageBounds
                FitImageBoundsToBox()
                GenerateLowResImages(_Image)
                InvalidateChangedBounds(oldBounds, _ImageBounds)
            End If
        End Set
    End Property

    <DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden),
    Description("The bounding rectangle of the zoomed image relative to the control origin.")>
    Public Property ImageBounds() As RectangleF
        Get
            Return _ImageBounds
        End Get
        Private Set(value As RectangleF)
            Dim oldBounds As RectangleF = _ImageBounds
            _ImageBounds = SafeBounds(value)
            InvalidateChangedBounds(oldBounds, _ImageBounds)
        End Set
    End Property

    <DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden),
    Description("Location of the top left corner of the zoomed image relative to the control origin.")>
    Public Property ImagePosition() As PointF
        Get
            Return _ImageBounds.Location
        End Get
        Set(ByVal value As PointF)
            ImageBounds = New RectangleF(value.X, value.Y, _ImageBounds.Width, _ImageBounds.Height)
        End Set
    End Property

    <Category("_ZoomPictureBox"),
    Description("The maximum zoom magnification.")>
    Public Property MaximumZoomFactor As Double
        Get
            Return _MaximumZoomFactor
        End Get
        Set(value As Double)
            _MaximumZoomFactor = value
        End Set
    End Property

    <Category("_ZoomPictureBox"),
     Description("Minimum height of the zoomed image in pixels.")>
    Public Property MinimumImageHeight As Integer
        Get
            Return _MinimumImageHeight
        End Get
        Set(value As Integer)
            _MinimumImageHeight = value
        End Set
    End Property

    <Category("_ZoomPictureBox"),
     Description("Minimum width of the zoomed image in pixels.")>
    Public Property MinimumImageWidth As Integer
        Get
            Return _MinimumImageWidth
        End Get
        Set(value As Integer)
            _MinimumImageWidth = value
        End Set
    End Property

    <Category("_ZoomPictureBox"),
     Description("Sets the responsiveness of zooming to the mouse wheel. Choose a lower value for faster zooming.")>
    Public Property MouseWheelDivisor As Integer
        Get
            Return _MouseWheelDivisor
        End Get
        Set(value As Integer)
            _MouseWheelDivisor = value
        End Set
    End Property

    <DesignerSerializationVisibility(DesignerSerializationVisibility.Hidden),
    Description("Linear size of the zoomed image as a fraction of that of the source Image.")>
    Public Property ZoomFactor() As Double
        Get
            Return _ZoomFactor
        End Get
        Set(ByVal value As Double)
            _ZoomFactor = ValidateZoomFactor(value)
            ImageBounds = GetZoomedBounds()
        End Set
    End Property

    <Category("_ZoomPictureBox"),
    DefaultValue(ZoomType.MousePosition),
    Description("Image zooming around the mouse position, image center or  control center")>
    Public Property ZoomMode() As ZoomType
        Get
            Return _ZoomMode
        End Get
        Set(ByVal value As ZoomType)
            _ZoomMode = value
        End Set
    End Property

#End Region

#Region "Property backing fields"
    Private _ImageBounds As RectangleF
    Private _ZoomFactor As Double = 1
    Private _Image As Image
    Private _startDrag As Point
    Private _dragging As Boolean
    Private _scrolling As Boolean
    Private _ZoomMode As ZoomType = ZoomType.MousePosition
    Private _MouseWheelDivisor As Integer = 4000
    Private _MinimumImageWidth As Integer = 10
    Private _MinimumImageHeight As Integer = 10
    Private _MaximumZoomFactor As Double = 64
    Private _EnableMouseWheelZooming As Boolean = True
    Private _EnableMouseWheelDragging As Boolean = True
    Private _SafeMargin As Integer = 30
#End Region

#Region "Other private variables"
    Private lowResImages As New List(Of Image)
    Private lowResIndex As Integer 'index to select a low res image
    'When this timer elapses after scroll-wheel zooming, the full resolution image is restored:
    Private WithEvents RenderDelayTimer As New System.Timers.Timer(100) With {.AutoReset = False}
#End Region

#Region "Enums"

    Public Enum ZoomType
        MousePosition
        ControlCenter
        ImageCenter
    End Enum

#End Region

#Region "Event handlers and overrides"

    Protected Overrides Sub initlayout()
        MyBase.InitLayout()
        If Me.Image IsNot Nothing Then FitImageBoundsToBox()
        Me.Invalidate()
    End Sub

    'Start image dragging
    Protected Overrides Sub OnMouseDown(ByVal e As System.Windows.Forms.MouseEventArgs)
        If EnableMouseDragging AndAlso e.Button = Windows.Forms.MouseButtons.Left Then
            _startDrag = e.Location
            _dragging = True
        End If
        MyBase.OnMouseDown(e)
    End Sub

    'Drag the image with the Mouse
    Protected Overrides Sub OnMouseMove(ByVal e As System.Windows.Forms.MouseEventArgs)
        If _dragging Then
            Dim X As Single = _ImageBounds.X + e.X - _startDrag.X
            Dim Y As Single = _ImageBounds.Y + e.Y - _startDrag.Y
            ImageBounds = New RectangleF(X, Y, _ImageBounds.Width, _ImageBounds.Height)
            _startDrag = e.Location
        End If
        MyBase.OnMouseMove(e)
        Me.Invalidate()
    End Sub

    'Terminate low-res at end of dragging
    Protected Overrides Sub OnMouseUp(ByVal e As System.Windows.Forms.MouseEventArgs)
        _dragging = False
        Me.Invalidate()
        MyBase.OnMouseUp(e)
    End Sub

    'The control only raises MouseWheel events when it has Focus.
    Protected Overrides Sub OnMouseEnter(ByVal e As System.EventArgs)
        Me.Select()
        MyBase.OnMouseEnter(e)
    End Sub

    'Mouse wheel zooming.
    Protected Overrides Sub OnMouseWheel(ByVal e As System.Windows.Forms.MouseEventArgs)
        If Me.EnableMouseWheelZooming AndAlso
        Me.ClientRectangle.Contains(e.Location) Then
            Dim oldbounds As RectangleF = _ImageBounds
            Dim zoom As Double = _ZoomFactor
            Dim accelerator As Double = (1 + 0.0005 / zoom) 'faster zooming at very low zoom factors
            zoom *= 1 + e.Delta * accelerator / _MouseWheelDivisor
            ZoomFactor = zoom
            InvalidateChangedBounds(oldbounds, _ImageBounds)
            _scrolling = True 'activate low-res zooming
            RenderDelayTimer.Start() 'terminate low-res zooming when the timer elapses
        End If
        MyBase.OnMouseWheel(e)
    End Sub

    'Render the image In the _ImageBounds rectangle.
    Protected Overrides Sub OnPaint(ByVal pe As System.Windows.Forms.PaintEventArgs)
        pe.Graphics.PixelOffsetMode = Drawing2D.PixelOffsetMode.Half
        pe.Graphics.InterpolationMode = Drawing2D.InterpolationMode.NearestNeighbor

        'draw a dotted image boundary (to show bounds of images with extensive transparency)
        Using pn As New Pen(Color.Black, 1) With {.DashPattern = {1, 3}}
            pe.Graphics.DrawRectangle(pn, Rectangle.Ceiling(_ImageBounds))
        End Using

        If lowResImages.Count > 0 Then
            If _ZoomFactor < 1 AndAlso (_dragging OrElse _scrolling) Then
                'for low zoom factor, select the smallest low res image 
                Do
                    If (lowResIndex < lowResImages.Count - 2) AndAlso (_ZoomFactor < 0.5 ^ (lowResIndex + 1)) Then
                        lowResIndex += 1
                    Else
                        Exit Do
                    End If
                Loop
            ElseIf _dragging Then
                'select a low res image during dragging up to 1/4 the full size:
                lowResIndex = Math.Min(lowResImages.Count - 1, 2)
            Else
                'full resolution
                lowResIndex = 0
            End If
            pe.Graphics.DrawImage(lowResImages(lowResIndex), _ImageBounds)
        End If

        MyBase.OnPaint(pe)
    End Sub

    'Prevent the image disappearing off screen when the size changes at runtime.
    Protected Overrides Sub OnSizeChanged(e As EventArgs)
        _ImageBounds = SafeBounds(_ImageBounds)
        MyBase.OnSizeChanged(e)
    End Sub

    'Timer to reduce full-res rendering during mouse wheel zooming:
    Private Sub RenderDelayTimer_Elapsed(sender As Object, e As Timers.ElapsedEventArgs) Handles RenderDelayTimer.Elapsed
        _scrolling = False
        Me.Invalidate()
    End Sub

#End Region

#Region "Public Methods"

    'Function to get the Image pixel corresponding to the mouse position:
    Public Function PointToImage(p As PointF) As Point
        Dim x, y As Integer
        x = CInt((p.X - ImagePosition.X) / _ZoomFactor)
        y = CInt((p.Y - ImagePosition.Y) / _ZoomFactor)
        Return New Point(x, y)
    End Function

    'To do: 
    ''Save the zoom and image position
    'Public Sub SaveView(ByRef zoomFactor As Double, ByRef imagePosition As PointF)
    '   zoomFactor = Me.ZoomFactor
    '   imagePosition = Me.ImagePosition
    'End Sub

    ''Restore the saved zoom and image position
    'Public Sub RestoreView(zoomFactor As Double, imageposition As PointF)
    '   Me.ZoomFactor = zoomFactor
    '   Me.ImagePosition = imageposition
    'End Sub

    'Fit the image bounds to the control (similar to Picturebox.SizeMode = Zoom):
    Public Sub FitImageBoundsToBox()
        If _Image IsNot Nothing Then
            ZoomFactor = GetInitialZoomFactor()
            ImageBounds = CenterImageBounds()
        End If
    End Sub

#End Region

#Region "Private methods"

    'Apply the maximum and minimum zoom limits:
    Private Function ValidateZoomFactor(ByVal zoom As Double) As Double
        zoom = Math.Min(zoom, MaximumZoomFactor)
        If _Image IsNot Nothing Then
            If CInt(_Image.Width * zoom) < MinimumImageWidth Then
                zoom = MinimumImageWidth / _Image.Width
            End If
            If CInt(_Image.Height * zoom) < MinimumImageHeight Then
                zoom = MinimumImageHeight / _Image.Height
            End If
        End If
        Return zoom
    End Function

    'Constrain panning within the safe margin, prevent the image moving "off screen" 
    Private Function SafeBounds(imgBounds As RectangleF) As RectangleF
        If _SafeMargin > 0 Then
            Dim dx As Integer = Math.Min(_SafeMargin, CInt(imgBounds.Width / 2))
            Dim dy As Integer = Math.Min(_SafeMargin, CInt(imgBounds.Height / 2))
            imgBounds.X = Math.Max(dx - imgBounds.Width, imgBounds.X) 'left
            imgBounds.X = Math.Min(Me.ClientSize.Width - dx, imgBounds.X) 'right
            imgBounds.Y = Math.Max(dy - imgBounds.Height, imgBounds.Y) 'top
            imgBounds.Y = Math.Min(Me.ClientSize.Height - dy, imgBounds.Y) 'bottom
        End If
        Return imgBounds
    End Function

    'Get the initial ZoomFactor to fit the image to the control (like PictureBox.SizeMode=Zoom)
    Private Function GetInitialZoomFactor() As Double
        If Me.Image Is Nothing OrElse Me.ClientSize = Size.Empty Then Return 1
        Dim sourceAspect As Double = _Image.Width / _Image.Height
        Dim targetAspect As Double = Me.ClientSize.Width / Me.ClientSize.Height
        If sourceAspect > targetAspect Then
            Return Me.ClientSize.Width / _Image.Width
        Else
            Return Me.ClientSize.Height / _Image.Height
        End If
    End Function

    'Center the zoomed image in the control bounds.
    Private Function CenterImageBounds() As RectangleF
        If Me.Image Is Nothing Then Return RectangleF.Empty
        Dim w As Integer = CInt(_Image.Width * _ZoomFactor)
        Dim h As Integer = CInt(_Image.Height * _ZoomFactor)
        Dim x As Integer = (Me.ClientSize.Width - w) \ 2
        Dim y As Integer = (Me.ClientSize.Height - h) \ 2
        Return New RectangleF(x, y, w, h)
    End Function

    'Calculate the image bounds for a changed ZoomFactor,  
    Private Function GetZoomedBounds() As RectangleF
        Static _previouszoomfactor As Double = 1
        If _ImageBounds = RectangleF.Empty OrElse _Image Is Nothing Then Return RectangleF.Empty

        'Find the zooming focus relative to the image bounds.
        Dim zoomFocus As PointF = FindZoomFocus(_ZoomMode)

        'Calculate the new size of the the image bounds.
        _previouszoomfactor = _ImageBounds.Width / _Image.Width
        If Math.Abs(_ZoomFactor - _previouszoomfactor) > 0.001 Then
            _ImageBounds.Width = CSng(_Image.Width * _ZoomFactor)
            _ImageBounds.Height = CSng(_Image.Height * _ZoomFactor)

            'Find the notional position of the zooming focus due to resizing.
            Dim dx As Single = CSng(zoomFocus.X * ZoomFactor / _previouszoomfactor)
            Dim dy As Single = CSng(zoomFocus.Y * ZoomFactor / _previouszoomfactor)

            'Apply a correction to return the zooming focus to its original position (so that it does not actually move).
            _ImageBounds.X += zoomFocus.X - dx
            _ImageBounds.Y += zoomFocus.Y - dy
        End If
        _previouszoomfactor = _ZoomFactor
        Return _ImageBounds
    End Function

    'Find the zooming focus relative to the image bounds, depending on the current zoom mode.
    Private Function FindZoomFocus(ByVal type As ZoomType) As PointF
        Dim p As PointF
        Select Case type
            Case ZoomType.ControlCenter
                p.X = Me.Width / 2.0F - _ImageBounds.X
                p.Y = Me.Height / 2.0F - _ImageBounds.Y
            Case ZoomType.ImageCenter
                p.X = _ImageBounds.Width / 2.0F
                p.Y = _ImageBounds.Height / 2.0F
            Case ZoomType.MousePosition
                Dim mp As Point = Me.PointToClient(MousePosition)
                If _ImageBounds.Contains(mp) Then 'Zoom to mouse position.
                    p.X = mp.X - _ImageBounds.X
                    p.Y = mp.Y - _ImageBounds.Y
                Else 'If the mouse pointer is outside image bounds, zoom to image center.
                    p.X = _ImageBounds.Width / 2.0F
                    p.Y = _ImageBounds.Height / 2.0F
                End If
            Case Else
                p = PointF.Empty
        End Select
        Return p
    End Function

    'Generate low resolution images for more efficient zooming/panning of large images.
    Private Sub GenerateLowResImages(img As Image)
        lowResImages = New List(Of Image)({img})
        Dim w As Integer = _Image.Width : Dim h As Integer = _Image.Height
        Do Until (w * h) < (256 * 256)
            lowResImages.Add(New Bitmap(_Image, w, h))
            w \= 2 : h \= 2
        Loop
    End Sub

    'Repaint the "dirty" part of the client area:
    Private Sub InvalidateChangedBounds(oldBounds As RectangleF, newBounds As RectangleF)
        Dim r As Rectangle = Rectangle.Ceiling(oldBounds)
        r.Inflate(5, 5)
        Me.Invalidate(r)
        r = Rectangle.Ceiling(newBounds)
        r.Inflate(5, 5)
        Me.Invalidate(r)
    End Sub

#End Region

End Class