Tipp-Upload: VB.NET 0176: Schnelles Bitmap-Zeichnen mit Lockbits

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Fenster
• Grafik

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Lockbits,GDI,ScrollableControl,Ownerdraw,Drawing

Der Vorschlag wurde erstellt am: 13.01.2008 06:24.
Die letzte Aktualisierung erfolgte am 22.12.2011 22:32.

Zurück zur Übersicht

Beschreibung  

Das Zeichnen von Ausschnitten einer großen Bitmap ist ungebührlich langsam. Eine erhebliche Optimierung stellt es dar, wenn zunächst mit Lockbits aus dem Ausschnitt eine kleine Bitmap erzeugt wird, welche dann gezeichnet wird. (Dieser des Pudels Kern findet sich in "Helpers.vb".)
Der Upload enthält ein für die Demonstration des Effektes eigentlich zu kleines Bild ( > 1 MB empfohlen ).
Vergleiche mit  Tippvorschlag 7 ,"Pictureviewer mit Autoscroll".
Dieser TU ist in VB2008 geschrieben, aber einfach umzuschreiben, indem man die Extension-Functions auf herkömmliche Weise aufruft.

Meinungen und Verbesserungen bitte hier posten:
http://foren.activevb.de/cgi-bin/foren/view.pl?forum=6&root=59912&msg=59912

Schwierigkeitsgrad

Verwendete API-Aufrufe:

Download: Download des Beispielprojektes [36,77 KB]

' Dieser Source 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!
'
' Beachten Sie, das vom Designer generierter Code hier ausgeblendet wird.
' In den Zip-Dateien ist er jedoch zu finden.

' --------- Anfang Projektgruppe QuickPicViewer.sln  ---------
' ----------- Anfang Projektdatei PicViewer.vbproj -----------
' -------------- Anfang Datei PictureViewer.vb  --------------
Imports System.ComponentModel
Partial Public Class PictureViewer
    Inherits ScrollableControl

    Private Shared _DummiBmp As New Bitmap(1, 1)
    Private _Bitmap As Bitmap = _DummiBmp
    Private _Backbrush As New SolidBrush(MyBase.BackColor)
    Private _Zoom As Single = 1
    Private _Scrollpos As PointF
    Private _ZoomMode As Boolean = Nothing

    Public Sub New()

        Me.SetStyle(ControlStyles.UserPaint Or ControlStyles.AllPaintingInWmPaint Or _
            ControlStyles.Opaque Or ControlStyles.OptimizedDoubleBuffer, True)

    End Sub

    Protected Overrides Sub OnPaint(ByVal e As PaintEventArgs)

        Try

            With e.ClipRectangle

                If .Width = 0 OrElse .Height = 0 Then Return
            End With

            If _Bitmap Is Nothing Then
                e.Graphics.Clear(MyBase.BackColor)
                Return
            End If

            With e.Graphics
                .PixelOffsetMode = Drawing2D.PixelOffsetMode.Half
                .SmoothingMode = Drawing2D.SmoothingMode.None
                .InterpolationMode = Drawing2D.InterpolationMode.NearestNeighbor
            End With

            Dim blitRects = CalculateBlitRects(e.ClipRectangle)

            ' e.Graphics.DrawImage(_Bitmap, blitRects(1), blitRects(0), GraphicsUnit.Pixel)
            e.Graphics.DrawFast(_Bitmap, blitRects(1), blitRects(0))

            If blitRects(1) <> e.ClipRectangle Then

                ' das berechnete zielRect weicht vom ClipRectangle ab (kann nur kleiner sein)
                For Each R In blitRects(1).Outersect(e.ClipRectangle)

                    ' ungezeichnete Randbereiche füllen
                    If R.Width > 0 AndAlso R.Height > 0 Then e.Graphics.FillRectangle(_Backbrush, R)
                Next

            End If

        Finally

            MyBase.OnPaint(e)

        End Try

    End Sub

    ' '' <summary>transformiert rct von ClientSize auf Bitmap-Abmaße bzw. annersrum</summary>
    Private Function TransForm(ByVal rct As Rectangle, ByVal toBitmap As Boolean) As Rectangle

        Dim translation = New Size(_Scrollpos.Round)

        If toBitmap Then
            rct.Location += translation
            Return rct.Mult(1 / _Zoom).RoundX(True)     ' Bild-Quell- Bereich ist Zoom-reziprok

        Else

            TransForm = rct.Mult(_Zoom).Round
            TransForm.Location -= translation
        End If

    End Function

    ' '' <summary>returnt 2 Rectangles (quelle, ziel), die beim zeichnen anzugeben sind</summary>
    Private Function CalculateBlitRects(ByVal destination As Rectangle) As Rectangle()

        ' transformieren
        Dim srcOrig = TransForm(destination, True)
        Dim src = srcOrig

        ' zuschneiden
        src.Intersect(_Bitmap.Size)
        ' rücktransformieren
        destination = TransForm(src, False)
        With destination
            .Intersect(ClientRectangle)                                    ' evtl.
                                                                           ' Rundungsfehler
                                                                           ' wegschneiden

            If src <> srcOrig Then

                ' src lag teilw. ausserhalb von _Bitmap.Size und wurde per Intersect
                ' zugeschnitten. Nun die
                ' °rücktransforierte, verkleinerte destination in x- und/oder y-Richtung zentrieren.
                Dim szC = ClientSize

                ' x-Richtung wurde beschnitten
                If src.Width < srcOrig.Width Then
                    .X = CInt((szC.Width - .Width) / 2)
                End If

                ' y-Richtung wurde beschnitten
                If src.Height < srcOrig.Height Then
                    .Y = CInt((szC.Height - .Height) / 2)
                End If
            End If

        End With

        Return New Rectangle() {src, destination}

    End Function

    Protected Overrides Sub OnBackColorChanged(ByVal e As System.EventArgs)

        _Backbrush.Dispose()
        _Backbrush = New SolidBrush(MyBase.BackColor)
        MyBase.OnBackColorChanged(e)

    End Sub

    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)

        If disposing Then _Backbrush.Dispose()
        MyBase.Dispose(disposing)

    End Sub

    <DesignerSerializationVisibilityAttribute(DesignerSerializationVisibility.Hidden)> Public _
        Property Scrollpos() As PointF

        ' unglaubliches Fehldesign an ScrollableControl.AutoScrollPosition: der Getter returnt die
        ' ! Inversion des Setters!
        Get
            Return _Scrollpos

        End Get

        Set(ByVal Value As PointF)
            Value = New RectangleF(Value, ClientSize).ClipIn(_Bitmap.Size.Mult(_Zoom)).Location

            If _Scrollpos.Round = Value.Round Then Return
            _Scrollpos = Value

            If _ZoomMode Then Return
            MyBase.AutoScrollPosition = Value.Round

        End Set

    End Property

    Protected Overrides Sub OnScroll(ByVal se As System.Windows.Forms.ScrollEventArgs)

        MyBase.OnScroll(se)

        With _Scrollpos

            If se.ScrollOrientation = ScrollOrientation.HorizontalScroll Then
                Scrollpos = New PointF(se.NewValue, .Y)

            Else

                Scrollpos = New PointF(.X, se.NewValue)
            End If

        End With

    End Sub

    Protected Property ZoomMode() As Boolean
        Get
            Return _ZoomMode

        End Get

        Set(ByVal value As Boolean)

            If _ZoomMode = value Then Return
            _ZoomMode = value

            If Not value Then
                MyBase.AutoScrollMinSize = _Bitmap.Size.Mult(_Zoom).Round
                MyBase.AutoScrollPosition = _Scrollpos.Round
            End If

            Me.Invalidate()

        End Set

    End Property

    Public Property Zoom() As Single
        Get
            Return _Zoom

        End Get

        Set(ByVal value As Single)

            If _Zoom = value Then Return
            ZoomMode = True

            Dim DeltaZoom As Single = value / _Zoom

            _Zoom = value

            Dim PanelMid = MyBase.ClientSize.Mult(0.5F)
            Dim ViewMid = (Me.Scrollpos + PanelMid).Mult(DeltaZoom)

            ' rctView ist der angezeigte Bildausschnitt über dem gezoomten Bild. Es sollte
            ' das Bild in
            ' °keiner Richtung überschreiten, es sei denn, rctView ist größer. Dann soll er in alle
            ' °Richtungen gleichmäßig überschreiten.
            Dim rctView = New RectangleF(ViewMid - PanelMid, ClientSize)

            Scrollpos = rctView.ClipIn(_Bitmap.Size.Mult(_Zoom)).Location
            Invalidate()
            AddHandler Application.Idle, AddressOf Application_Idle

        End Set

    End Property

    Private Sub Application_Idle(ByVal sender As Object, ByVal e As EventArgs)

        RemoveHandler Application.Idle, AddressOf Application_Idle

        ' sobald die Maus nachm Zoomen losgelassen wird, ZoomMode abschalten
        If Control.MouseButtons = MouseButtons.None Then ZoomMode = False

    End Sub

    ''' <summary>
    ''' projeziert einen Punkt des Controls auf die Fläche des virtuellen 
    ''' Views (BitmapSize * Zoom)
    ''' </summary>
    Public Function ScaleToVirtual(ByVal Ptf As PointF) As PointF

        With New SizeF(MyBase.AutoScrollMinSize)
            Return Ptf.Scale(.Width / ClientSize.Width, .Height / ClientSize.Height)
        End With

    End Function

    Public Property Bitmap() As Bitmap
        Get
            Return _Bitmap

        End Get

        Set(ByVal value As Bitmap)
            _Bitmap = If(value, _DummiBmp)
            MyBase.AutoScrollMinSize = _Bitmap.Size.Mult(_Zoom).Round
            Invalidate()

        End Set

    End Property

End Class

' --------------- Ende Datei PictureViewer.vb  ---------------
' ------------------ Anfang Datei Form1.vb  ------------------
Imports System
Imports System.Collections.Generic
Imports System.ComponentModel
Imports System.Drawing
Imports System.Text
Imports System.Windows.Forms
Imports System.IO
Imports System.Runtime.InteropServices

Partial Public Class Form1
    Inherits Form

    Private _PicSource As New Bitmap(1, 1)

    Private _PointSizeFormat As String = "({0:0} / {1:0})"
    Private _GrabOffs As PointF

    Private Function PointToString(ByVal sz As PointF) As String

        Return String.Format(_PointSizeFormat, sz.X, sz.Y)

    End Function

    Private Function SizeToString(ByVal sz As SizeF) As String

        Return String.Format(_PointSizeFormat, sz.Width, sz.Height)

    End Function

    Public Sub New()

        InitializeComponent()
        Location = Screen.PrimaryScreen.WorkingArea.Location

        ' ExchangePicSource("nevermore.jpg")
        ExchangePicSource("C:\Programming\Ressources\TestPictures\BigJpg.JPG")

    End Sub

    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)

        If disposing Then
            If _PicSource IsNot Nothing Then
                _PicSource.Dispose()
            End If

            If components IsNot Nothing Then
                components.Dispose()
            End If
        End If

        MyBase.Dispose(disposing)

    End Sub

    Private Sub ExchangePicSource(ByVal sPath As String)

        Dim bmpNew As Bitmap
        Dim FileName As String = Path.GetFileName(sPath)

        Try

            bmpNew = New Bitmap(sPath)

        Catch ex As Exception

            MessageBox.Show(ex.ToString, String.Concat("""", FileName, """ einlesen gescheitert"))
            Return

        End Try

        _PicSource.Dispose()
        _PicSource = bmpNew
        Me.PictureViewer1.Bitmap = _PicSource
        lbBitmapSize.Text = SizeToString(_PicSource.Size)
        MyBase.Text = String.Concat(Application.ProductName, " - ", FileName)
        PictureViewer1.Scrollpos = PointF.Empty

        ' ApplyZoom()
    End Sub

    Private Sub ApplyZoom()

        ' gezoomt wird exponentiell, von 2^-7 bis 2^+7
        Dim ZoomVal = CSng(Math.Pow(2, ZoomScrollBar.ScaledValue(-7, 7)))

        PictureViewer1.Zoom = ZoomVal
        lbVirtualSize.Text = SizeToString(PictureViewer1.AutoScrollMinSize)
        lbZoom.Text = ZoomVal.ToString("0.0000")

    End Sub

    Private Sub PictureViewer1_MouseDown(ByVal sender As Object, ByVal e As MouseEventArgs) _
                 Handles PictureViewer1.MouseDown

        ' ScaleToVirtual ist erforderlich, um die überproportionalen Bewegungen der
        ' PV.SrollPos zu erzeugen. Eine Mausbewegung übers Fenster soll die ganze Bitmap
        ' durchlaufen. Da der PV nur einen Ausschnitt der Bitmap anzeigt, muß die Bewegung
        ' der PV.ScrollPos entsprechend überproportional sein.
        ' ScaleToVirtual projeziert die MausPos auf die viel größere virtuelle Gesamtfläche des PV
        _GrabOffs = PictureViewer1.ScaleToVirtual(e.Location).SubtractX(PictureViewer1.Scrollpos)

    End Sub

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

        With Me.PictureViewer1

            If e.Button = MouseButtons.Left Then

                Dim Scrollpos = .ScaleToVirtual(e.Location).SubtractX(_GrabOffs)

                .Scrollpos = Scrollpos
                Me.lbScrollPos.Text = PointToString(Scrollpos)
            End If

            lbMouseOnBitmap.Text = PointToString(e.Location.Add(.Scrollpos).Mult(1 / .Zoom))
        End With

    End Sub

    Private Sub ZoomScrollBar_ValueChanged(ByVal sender As Object, ByVal e As EventArgs) _
              Handles ZoomScrollBar.ValueChanged

        ApplyZoom()

    End Sub

    Private Sub Button1_Click(ByVal sender As Object, ByVal e As EventArgs) Handles button1.Click

        If Me.OpenFileDialog1.ShowDialog() = DialogResult.OK Then
            ExchangePicSource(Me.OpenFileDialog1.FileName)
        End If

    End Sub

    Private Sub PictureViewer1_SizeChanged(ByVal sender As Object, ByVal e As EventArgs) _
              Handles PictureViewer1.SizeChanged

        Me.lbSectionSize.Text = SizeToString(PictureViewer1.Size)

    End Sub

    Private Sub PictureViewer1_Scroll(ByVal sender As Object, ByVal e As ScrollEventArgs) _
              Handles PictureViewer1.Scroll

        Me.lbScrollPos.Text = PointToString(PictureViewer1.Scrollpos)

    End Sub

    Private Sub Form1_KeyDown(ByVal sender As System.Object, ByVal e As _
        System.Windows.Forms.KeyEventArgs) Handles MyBase.KeyDown

    End Sub

End Class

' ------------------- Ende Datei Form1.vb  -------------------
' ----------------- Anfang Datei Helpers.vb  -----------------
Imports System.Runtime.CompilerServices
Imports System.Drawing.Imaging

Public Module Helpers

    ''' <summary>Optimierung für Graphics.DrawImage()</summary>
    ''' <remarks>"des Pudels Kern"</remarks>
    <Extension()> _
        Public Sub DrawFast(ByVal g As Graphics, ByVal bmp As Bitmap, _
              ByVal dest As Rectangle, ByVal src As Rectangle)

        If src.Width < 1 OrElse src.Height < 1 Then Return

        With bmp

            Dim bd As BitmapData = .LockBits(src, ImageLockMode.ReadOnly, .PixelFormat)

            Using bmpLocked As New Bitmap(src.Width, src.Height, bd.Stride, .PixelFormat, bd.Scan0)
                g.DrawImage(bmpLocked, dest)
            End Using

            .UnlockBits(bd)
        End With

    End Sub

    ''' <summary>
    ''' gibt die 4 Rechtecke zurück, die durch eine Intersection **ausgeschlossen** werden
    ''' </summary>
    <Extension()> _
        Friend Function Outersect( _
                ByVal Inside As Rectangle, ByVal Surround As Rectangle) As Rectangle()

        Inside.Intersect(Surround)

        Return New Rectangle() { RectFrom2Points(Surround.Left, Surround.Top, Inside.Right, _
            Inside.Top), RectFrom2Points(Surround.Left, Inside.Top, Inside.Left, _
            Surround.Bottom), RectFrom2Points(Inside.Left, Inside.Bottom, Surround.Right, _
            Surround.Bottom), RectFrom2Points(Inside.Right, Surround.Top, Surround.Right, _
            Inside.Bottom)}

    End Function

    Private Function RectFrom2Points( _
                ByVal X0 As Integer, ByVal Y0 As Integer, _
                ByVal X1 As Integer, ByVal Y1 As Integer) As Rectangle

        Return New Rectangle(X0, Y0, X1 - X0, Y1 - Y0)

    End Function

    ''' <summary>scaliert den Wert einer Scrollbar auf den Bereich 0 bis 1</summary>
    Public Function NormedScrollValue(ByVal Scrollbar As ScrollBar) As Single

        With Scrollbar
            Return Math.Min(CSng(.Value - .Minimum) / ((.Maximum - .Minimum) - .LargeChange), 1)
        End With

    End Function

    ''' <summary>scaliert den Wert einer Scrollbar auf den angegebenen Bereich</summary>
    <Extension()> _
        Public Function ScaledValue( _
                ByVal Scrollbar As ScrollBar, _
                ByVal ScaleMin As Single, _
                ByVal ScaleMax As Single) As Single

        Return NormedScrollValue(Scrollbar) * (ScaleMax - ScaleMin) + ScaleMin

    End Function

End Module

' ------------------ Ende Datei Helpers.vb  ------------------
' ------------ Ende Projektdatei PicViewer.vbproj ------------
' ---------- Ende Projektgruppe QuickPicViewer.sln  ----------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.