VB.NET-Tipp 0081: Picture-Viewer mit Autoscroll

 
' Dieser Quellcode stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' Projektversion:   Visual Studio 2005
' Option Strict:    An
'
' Referenzen: 
'  - System
'  - System.Data
'  - System.Drawing
'  - System.Windows.Forms
'  - System.Xml
'
' Imports: 
'  - Microsoft.VisualBasic
'  - Microsoft.VisualBasic.ControlChars
'  - System
'  - System.Collections
'  - System.Collections.Generic
'  - System.Data
'  - System.Drawing
'  - System.Diagnostics
'  - System.Windows.Forms
'

' ##############################################################################
' ############################ frmPictureViewer.vb #############################
' ##############################################################################
'Steuerelemente - Einstellungen:
'Panel "ScrollContainer", mit .AutoScroll = True
'Picturebox "DisplayControl", mit .BackgroundImageLayout.Zoom

Public Class frmPictureViewer
    Private _GrabOffs As SizeF

    Private Sub frmPictureViewer_Load(ByVal sender As Object, _
        ByVal e As EventArgs) Handles MyBase.Load

        Me.DisplayControl.BackgroundImage = New Bitmap(1, 1)
        ExchangePicSource("Bild 023.jpg")
    End Sub

    Private Sub ExchangePicSource(ByVal path As String)
        Dim bmpNew As Bitmap
        Dim FileName As String = IO.Path.GetFileName(path)
        Try
            bmpNew = New Bitmap(path)
        Catch ex As Exception
            MsgBox(String.Concat("""", FileName, """ einlesen gescheitert.", _
                Lf, Lf, "Fehlermeldung: ", Lf, ex.ToString), _
                MsgBoxStyle.Information)
            Return
        End Try

        DisplayControl.BackgroundImage.Dispose()
        DisplayControl.BackgroundImage = bmpNew

        ' Der spezifische Control-Typ - hier: Picturebox - ist gänzlich 
        ' unerheblich, denn über die BackgroundImage - Property verfügen 
        ' alle Controls
        lbBitmapSize.Text = SizeToString(bmpNew.Size)
        MyBase.Text = String.Concat(Application.ProductName, " - ", FileName)
        ApplyZoom()
    End Sub

    Private Sub ApplyZoom()
        Dim Msg As String = ""
        Dim ZoomVal As Double = GetZoom()
        Static OldZoom As Double = 1
        Dim NewSize As Size = _
            Mult(DisplayControl.BackgroundImage.Size, ZoomVal).ToSize

        ' Zu viele Bildpunkte erzeugen einen Pufferfehler im Control
        Const MaxPixCount As Long = 160000000
        If MaxPixCount > CLng(NewSize.Width) * NewSize.Height Then
            ' Zoomen ist damit getan
            Me.DisplayControl.Size = NewSize

            ' Aber die Bildmitte reorganisieren...
            KeepMiddle(ZoomVal / OldZoom)

            lbZoom.Text = ZoomVal.ToString("0.0000")
            OldZoom = ZoomVal
        Else
            Msg = "Zu groß! "
        End If
        Msg &= SizeToString(NewSize)
        lbDisplayerSize.Text = Msg
    End Sub

    Private Function GetZoom() As Double
        ' Gezoomt wird exponentiell, von 2^-7 bis 2^+7
        Return 2 ^ (Me.trkZoom.Value / 100)
    End Function

    ''' <summary>bisherige Bildmitte beibehalten</summary>
    ''' <remarks>
    ''' AutoScrollPosition bezeichnet die Position der Picbox. Da
    ''' diese beim Scrollen über pnlScroll hinausragt, ergeben sich
    ''' negative XY-Werte
    ''' </remarks>
    Private Sub KeepMiddle(ByVal deltaZoom As Double)
        Dim ContainerMid As Size = HalfSz(ScrollContainer.Size)

        '(AutoScrollPosition invertiert adden)
        Dim Middle As Size = ContainerMid - _
            New Size(ScrollContainer.AutoScrollPosition)
        Middle = Mult(Middle, deltaZoom).ToSize

        ' Verrückt: die neue AutoScrollPosition muß als positiver Wert 
        '  zugewiesen werden! Ruft man sie wieder ab, ist sie negativ?!?
        ScrollContainer.AutoScrollPosition = New Point(Middle) - ContainerMid
    End Sub

    Private Sub frmPictureViewer_Disposed(ByVal sender As Object, _
        ByVal e As EventArgs) Handles Me.Disposed

        DisplayControl.BackgroundImage.Dispose()
    End Sub

    Private Sub pnlScroll_SizeChanged(ByVal sender As Object, _
        ByVal e As EventArgs) Handles ScrollContainer.SizeChanged

        lbContainerSize.Text = SizeToString(ScrollContainer.Size)
    End Sub

    Private Sub DisplayControl_MouseDown(ByVal sender As Object, _
        ByVal e As MouseEventArgs) Handles DisplayControl.MouseDown

        _GrabOffs = New SizeF(Container2Display(MouseLocation)) + _
            New Size(Me.ScrollContainer.AutoScrollPosition)
    End Sub

    ''' <summary>
    '''  Lupe: bei gehaltenem Button **beide** Scrollbars bedienen
    ''' </summary>
    Private Sub DisplayControl_MouseMove(ByVal sender As Object, _
        ByVal e As MouseEventArgs) Handles DisplayControl.MouseMove

        If e.Button = Windows.Forms.MouseButtons.Left Then
            Me.ScrollContainer.AutoScrollPosition = _
                Point.Round(Container2Display(MouseLocation) - _GrabOffs)
        End If
        lbMouseOnBitmap.Text = e.Location.ToString
    End Sub

    Private Sub DisplayControl_Move(ByVal sender As Object, _
        ByVal e As EventArgs) _
        Handles DisplayControl.Move, DisplayControl.SizeChanged

        lbScrollPos.Text = Me.ScrollContainer.AutoScrollPosition.ToString
    End Sub

    Private Sub trkZoom_ValueChanged(ByVal sender As Object, _
        ByVal e As EventArgs) Handles trkZoom.ValueChanged

        ApplyZoom()
    End Sub

    Private Sub btDatei_Click(ByVal sender As Object, _
        ByVal e As EventArgs) Handles btDatei.Click

        With Me.OpenFileDialog1
            If .ShowDialog = Windows.Forms.DialogResult.OK Then _
                ExchangePicSource(.FileName)
        End With
    End Sub

    Private Function Container2Display(ByVal pointOnContainer As PointF) _
        As PointF

        ' Ermittelt den zu ptContainer proportionalen Punkt auf dem 
        '  Display-Control. Erforderlich für die Bewegungen der "Lupe". Eine 
        '  Mausbewegung quer über den Container soll ja das Display-Control 
        ' komplett durchscrollen.
        Dim Sz As New SizeF(DisplayControl.Size)
        Return modHelpers.Scale(pointOnContainer, _
           Sz.Width / MyBase.ClientSize.Width, _
           Sz.Height / MyBase.ClientSize.Height)
    End Function

    Private Function MouseLocation() As Point
        ' Die Mausposition relativ zum Container
        Return Me.ScrollContainer.PointToClient(Control.MousePosition)
    End Function

    Private Function SizeToString(ByVal sz As Size) As String
        Return String.Concat(sz.Width, " / ", sz.Height)
    End Function

    Private Sub btBugTest_Click(ByVal sender As Object, _
        ByVal e As EventArgs) Handles btBugTest.Click

        ' Bug-Demo: Die Eigenschaft Control.AutoScrollposition negiert sich 
        ' selbst, d.h. bei einer Scrollposition von { -5, -5 } bewirkt die 
        ' folgende (eigentlich idiotische) Zuweisung eine Änderung der 
        ' Scrollposition auf { 5, 5 }. Da es positive Scrollpositionen nicht 
        ' gibt, springt die Scrollposition auf { 0, 0 }.
        ScrollContainer.AutoScrollPosition = ScrollContainer.AutoScrollPosition
    End Sub
End Class

' ##############################################################################
' ################################ Helpers.vb ##################################
' ##############################################################################
Module modHelpers
    Public Function Mult(ByVal sz As SizeF, ByVal zoomValue As Double) As SizeF
        With sz
            Return New SizeF(CInt(.Width * zoomValue), _
                CInt(.Height * zoomValue))
        End With
    End Function

    Public Function Mult(ByVal pt As PointF, _
        ByVal zoomValue As Double) As PointF

        With pt
            Return New PointF(CInt(.X * zoomValue), CInt(.Y * zoomValue))
        End With
    End Function

    Public Function HalfSz(ByVal sz As Size) As Size
        With sz
            Return New Size(.Width \ 2, .Height \ 2)
        End With
    End Function

    Public Function Scale(ByVal pt As PointF, ByVal x As Single, _
        ByVal y As Single) As PointF

        With pt
            Return New PointF(.X * x, .Y * y)
        End With
    End Function
End Module

ScrollContainer.AutoScrollPosition = New Point(Middle) - ContainerMid

Control.AutoScrollPosition =New Point(X,Y)