Tipp-Upload: VB.NET 0261: Convolution-Filter

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Algorithmen
• Datenbanken und XML
• Grafik
• Listensteuerelemente

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
databinding,filter,grafikfilter

Der Vorschlag wurde erstellt am: 01.05.2008 00:55.
Die letzte Aktualisierung erfolgte am 15.01.2009 12:32.

Zurück zur Übersicht

Beschreibung  

Das Grafik-KnowHow dieses TUs ist einem TU Frank Schülers entnommen. "Nur" GUI und Algorithmus sind umgearbeitet.
Die Bild-Anwahl stellt eine Nutzanwendung von  VB.NET Tipp 89(DataBinding an KeyValuePair) dar.
Lesetipps: DGL-Wiki, vbAccelerator

Schwierigkeitsgrad

Verwendete API-Aufrufe:

Download: Download des Beispielprojektes [119,51 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 ConVolutionFilter.sln --------
' ------- Anfang Projektdatei ConVolutionFilter.vbproj -------
' -------------- Anfang Datei uclMatrixGrid.vb  --------------
' IDE-Voreinstellungen:
' Option Explicit On
' Option Strict On

' "My Project"-Einstellungen:
' Imports Microsoft.VisualBasic.ControlChars
' Imports System.Windows.Forms

Imports System.ComponentModel

''' <summary>kapselt ein quadratisches DataGridView</summary>
Public Class uclMatrixGrid

    Private ReadOnly _EdgeSize As Integer

    Public Sub New()

        InitializeComponent()
        _EdgeSize = Me.Grid.ColumnCount
        Me.Grid.RowCount = _EdgeSize

    End Sub

    ''' <summary>Werte als eindimensionales Array</summary>
    ''' <remarks>datenbindebar und speicherfähig</remarks>
    <Bindable(True)> Public Property Bytes() As SByte()
        Get

            Dim RetVal(_EdgeSize * _EdgeSize - 1) As SByte

            For Y As Integer = 0 To _EdgeSize - 1
                For X As Integer = 0 To _EdgeSize - 1
                    RetVal(Y * _EdgeSize + X) = CSByte(Me.Grid(X, Y).Value)
                Next
            Next

            Return RetVal

        End Get

        Set(ByVal NewValue As SByte())

            Dim Line(_EdgeSize - 1) As Object

            For Y As Integer = 0 To _EdgeSize - 1
                For X As Integer = 0 To _EdgeSize - 1
                    Me.Grid(X, Y).Value = NewValue(Y * _EdgeSize + X)
                Next
            Next

        End Set

    End Property

    ''' <summary>Werte als zweidimensionales Array</summary>
    ''' <remarks>verwendbar für Berechnungen</remarks>
    Public Function GetMatrix() As SByte(,)

        Dim RetVal(_EdgeSize - 1, _EdgeSize - 1) As SByte

        For Y As Integer = 0 To _EdgeSize - 1
            For X As Integer = 0 To _EdgeSize - 1
                RetVal(Y, X) = CSByte(Me.Grid(X, Y).Value)
            Next
        Next

        Return RetVal

    End Function

    Private Sub Grid_CellPainting( _
              ByVal sender As Object, ByVal e As DataGridViewCellPaintingEventArgs) _
              Handles Grid.CellPainting

        ' stellt die Spaltenüberschriften auch auf den Zeilenköpfen dar
        With Grid

            ' Die Zeilenköpfe werden mit ColumnIndex=-1 angesprochen
            If e.ColumnIndex < 0 AndAlso e.RowIndex >= 0 AndAlso e.RowIndex < .RowCount Then
                e.PaintBackground(e.CellBounds, False)

                TextRenderer.DrawText(e.Graphics, .Columns(e.RowIndex).HeaderText, .Font, _
                    e.CellBounds, .ForeColor)

                e.Handled = True
            End If

        End With

    End Sub

End Class

' --------------- Ende Datei uclMatrixGrid.vb  ---------------
' ----------- Anfang Datei frmConVolutionFilter.vb -----------
Imports System.Drawing.Imaging
Imports System.IO
Imports ConVolutionFilter.FilterDataSet
Imports PictureData = System.Collections.Generic.KeyValuePair(Of String, System.Drawing.Bitmap)

Public Class frmConVolutionFilter

    Private _DataFile As String = "DataFile.xml"
    Private _Pictures As New List(Of PictureData)

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

        AddHandler FilterDataSet.Filter.TableNewRow, AddressOf FilterTable_TableNewRow

        Dim PicDir As String = Path.GetFullPath("Pictures")
        Dim PicPathes As String() = Directory.GetFiles(PicDir)

        ' Alle Bilder in KeyValuePairs laden, und per Databinding an cmbSourcePic binden
        For Each sPath As String In PicPathes

            Try

                Dim S As String = Path.GetFileName(sPath)

                _Pictures.Add(New PictureData(S, New Bitmap(sPath)))

            Catch ex As Exception

                MsgBox(String.Concat("Das Bild", Lf, sPath, Lf, "konnte nicht erstellt " & _
                    "werden", Lf, "Vermutlich ist es keine Bilddatei, und sollte aus dem " & _
                    "Bilderordner entfernt werden"))

                Diagnostics.Process.Start(PicDir)

            End Try

        Next

        Me.cmbSourcePic.DisplayMember = "Key"
        cmbSourcePic.ValueMember = "Value"
        cmbSourcePic.DataSource = _Pictures

        ' SplitContainer2.Panel1.BackgroundImage an dieselbe DataSource binden
        Me.SplitContainer2.Panel1.DataBindings.Add("BackgroundImage", _Pictures, "Value")
        Reload()
        ApplyCurrentFilter()

    End Sub

    Private Sub Button_Click(ByVal sender As Object, ByVal e As EventArgs) _
              Handles btSave.Click, btReload.Click, btApplyFilter.Click, btRemoveFilter.Click

        Select Case True

            Case sender Is btSave
                Save()

            Case sender Is btReload
                Reload()

            Case sender Is btApplyFilter
                Me.DataGridView1.EndEdit()
                Me.FilterBindingSource.EndEdit()
                ApplyCurrentFilter()

            Case sender Is btRemoveFilter

                ExchangeDisposable(SplitContainer1.Panel2.BackgroundImage, New Bitmap( _
                    DirectCast(cmbSourcePic.SelectedValue, Image)))

        End Select

    End Sub

    Private Sub FilterTable_TableNewRow(ByVal sender As Object, ByVal e As DataTableNewRowEventArgs)

        ' Filtermatrix neuer Datensätze initialisieren
        With DirectCast(e.Row, FilterRow)
            .Matrix = New SByte() {0, 0, 0, 0, 1, 0, 0, 0, 0}
        End With

    End Sub

    Private Sub Save()

        Me.DataGridView1.EndEdit()
        Me.FilterBindingSource.EndEdit()
        Me.FilterDataSet.WriteXml(_DataFile)

    End Sub

    Private Sub Reload()

        If Not File.Exists(_DataFile) Then
            MsgBox("Es sind noch keine Filterdaten abgespeichert worden")
            Return
        End If

        Me.FilterDataSet.Filter.BeginLoadData()
        Me.FilterDataSet.Filter.Clear()
        Me.FilterDataSet.ReadXml(_DataFile)
        Me.FilterDataSet.Filter.EndLoadData()

    End Sub

    Private Sub ApplyCurrentFilter()

        ' Über jedes Pixel wird eine 3*3-Gewichtungs-Matrix gelegt, die darunter liegenden Werte
        ' ! gewichtet aufsummiert. Die Gesamtsumme wird durch den Divisor geteilt, um den
        ' ! Durchschnitts-Wert wieder herzustellen.
        ' Heben sich positive und negative Gewichtungen auf (Summe der Matrix = 0) so wird die
        ' ! Durchschnitts-Helligkeit des Bildes gewährleistet durch Addition eines Offsets von 127.
        If FilterBindingSource.Position < 0 Then Return

        Dim Filter As FilterRow = GetRow(Of FilterRow)(Me.FilterBindingSource.Current)
        Dim Img As Image = DirectCast(cmbSourcePic.SelectedValue, Image)
        Dim Helper As New PixelHelper(Img, PixelFormat.Format24bppRgb, ckGray.Checked)
        Dim Divisor As Single = Filter.Divisor
        Dim Offset As Short = Filter.Offset
        Dim ReadPixels As Byte(,) = Helper.ReadPixels
        Dim rpX, rpY As Integer
        Dim WritePixels As Byte(,) = Helper.CreateWritePixels(PixelFormat.Format24bppRgb)
        Dim wpX, wpY As Integer
        Dim Matrix As SByte(,) = Me.UclMatrixGrid1.GetMatrix
        Dim mtrX, mtrY As Integer
        Dim YUbound As Integer = Img.Height - 1
        Dim XUbound As Integer = Img.Width * 3 - 1

        ' Checkboxen steuern, welche Farbkanäle filtern, oder ob Grauwert-Konvertierung anwenden
        Dim FilterColor As Boolean() = New Boolean() {ckRed.Checked, ckGreen.Checked, _
            ckBlue.Checked}

        If ckGray.Checked Then FilterColor = New Boolean() {True, True, True}

        For IColor As Integer = 0 To 2

            If FilterColor(IColor) Then

                ' die Hauptschleife läßt die Ränder aus, da die Anwendung der Matrix auf Randpixel
                ' ! zu Array-Überschreitungen führt (s. Start- und End-Werte von wpY, wpX).
                For wpY = 1 To YUbound - 1

                    ' horizontal in 3-er Schritten iterieren, da die 3 FarbKomponenten der Pixel
                    ' ! hintereinander liegen
                    For wpX = IColor + 3 To XUbound - 3 Step 3

                        Dim WeightedSum As Double = 0

                        For mtrY = 0 To 2

                            ' Vertikalversatz zum Auslesen der Nachbarpixel
                            rpY = wpY + mtrY - 1

                            For mtrX = 0 To 2

                                ' Horizontalversatz in 3-er Schritten
                                rpX = wpX + (mtrX - 1) * 3
                                WeightedSum += ReadPixels(rpY, rpX) * Matrix(mtrY, mtrX)
                            Next
                        Next

                        WeightedSum = ClipBetween(0.0, WeightedSum / Divisor + Offset, 255.0)
                        WritePixels(wpY, wpX) = CByte(WeightedSum)
                    Next
                Next

                ' oberer und unterer Rand, incl. Eck-Pixel
                For wpY = 0 To YUbound Step YUbound
                    For wpX = IColor To XUbound Step 3

                        Dim WeightedSum As Double = ApplyMatrixSave(ReadPixels, Matrix, wpY, _
                            wpX, YUbound, XUbound)

                        WritePixels(wpY, wpX) = CByte(ClipBetween(0.0, WeightedSum / Divisor _
                            + Offset, 255.0))

                    Next
                Next

                ' linker und rechter Rand, Eck-Pixel auslassen
                For wpY = 1 To YUbound - 1
                    For wpX = IColor To XUbound Step XUbound - 2

                        Dim WeightedSum As Double = ApplyMatrixSave(ReadPixels, Matrix, wpY, _
                            wpX, YUbound, XUbound)

                        WritePixels(wpY, wpX) = CByte(ClipBetween(0.0, WeightedSum / Divisor _
                            + Offset, 255.0))

                    Next
                Next

            Else

                ' statt filtern Farbkomponente nur kopieren
                For wpY = 0 To YUbound
                    For wpX = IColor To XUbound Step 3
                        WritePixels(wpY, wpX) = ReadPixels(wpY, wpX)
                    Next
                Next

            End If

        Next

        ExchangeDisposable(Me.SplitContainer1.Panel2.BackgroundImage, Helper.GetResultBitmap)

    End Sub

    Private Function ApplyMatrixSave( _
                  ByVal ReadPixels As Byte(,), _
                  ByVal Matrix As SByte(,), _
                  ByVal wpY As Integer, _
                  ByVal wpX As Integer, _
                  ByVal YUbound As Integer, _
                  ByVal XUbound As Integer) As Double

        ' wendet die Matrix auf ein Pixel an, unter Absicherung gegen Arrayüberschreitungen in
        ' ! alle 4 Richtungen
        Dim WeightedSum As Double = 0

        For mtrY As Integer = 0 To 2

            ' ReadPixel-Y wird in den Y-Array-Grenzen geclippt
            Dim rpY As Integer = ClipBetween(0, wpY + mtrY - 1, YUbound)

            For mtrX As Integer = 0 To 2

                Dim rpX As Integer = wpX + (mtrX - 1) * 3

                ' Bei Randüberschreitung muß rpX um 3 Bytes versetzt werden, um dieselbe
                ' ! Farbkomponente des horizontalen Nachbarpixels auszulesen
                If rpX < 0 Then
                    rpX += 3

                ElseIf rpX > XUbound Then

                    rpX -= 3
                End If

                WeightedSum += ReadPixels(rpY, rpX) * Matrix(mtrY, mtrX)
            Next
        Next

        Return WeightedSum

    End Function

    Private Sub FilterBindingSource_CurrentChanged(ByVal sender As Object, ByVal e As _
        EventArgs) Handles FilterBindingSource.CurrentChanged, _
        cmbSourcePic.SelectedValueChanged, ckRed.CheckedChanged, ckGreen.CheckedChanged, _
        ckBlue.CheckedChanged, ckGray.CheckedChanged

        ApplyCurrentFilter()

    End Sub

End Class

' ------------ Ende Datei frmConVolutionFilter.vb ------------
' ---------------- Anfang Datei modHelpers.vb ----------------
Imports System
Imports System.Collections

Public Module modHelpers

    Public Function EnumGetName(Of T As Structure)(ByVal Value As T) As String

        Return [Enum].GetName(GetType(T), Value)

    End Function

    Public Sub ExchangeDisposable(Of T As IDisposable, T2 As T)(ByRef Dest As T, ByVal Src As T2)

        If Dest IsNot Nothing Then Dest.Dispose()
        Dest = Src

    End Sub

    Public Sub DisposeManaged(Of T As IDisposable)(ByRef Disposable As T)

        If Disposable Is Nothing Then Return
        Disposable.Dispose()

    End Sub

    Public Function ClipBetween(Of T As IComparable)( _
              ByVal Bord0 As T, _
              ByVal ToTest As T, _
              ByVal Bord1 As T) As T

        If Bord0.CompareTo(ToTest) > 0 Then Return Bord0
        If Bord1.CompareTo(ToTest) < 0 Then Return Bord1
        Return ToTest

    End Function

    ''' <summary>einfache Debug-Ausgabe, nimmt alles, unkaputtbar</summary>
    Public Sub Dbg(ByVal ParamArray Args As Object())

        Dim Args2(Args.Length * 2 - 1) As Object

        For i As Integer = 0 To Args.Length - 1
            Args2(i * 2) = Args(i)
            Args2(i * 2 + 1) = " "
        Next

        Console.WriteLine(String.Concat(Args2))

    End Sub

    ''' <summary>
    ''' Ermittelt die typisierte Row eines als Object übergebenen DataRowViews
    ''' Bsp: Name = GetRow(Of OrderDataset.CustomerRow)(CustomerBindingSource.Current).Name
    ''' </summary>
    Public Function GetRow(Of T As DataRow)(ByVal Current As Object) As T

        If Current Is Nothing Then Return Nothing
        Return DirectCast(DirectCast(Current, DataRowView).Row, T)

    End Function

End Module

' ----------------- Ende Datei modHelpers.vb -----------------
' --------------- Anfang Datei PixelHelper.vb  ---------------
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices

''' <summary>
''' verschafft sich Zugriff auf die Pixeldaten von Images, in Form von 2-dim Byte-Arrays
''' </summary>
Public Class PixelHelper

    ' Der übliche Zugang zu Pixeldaten über Bitmap.LockBits() impliziert 4 Kopiervorgänge der
    ' ! gesamten Bitmap: Lock/Unlock, und dann jeweils Marshall.Copy() in ein managed Array.
    ' Die Bitmap-Erstellung unter Verwendung gepinnter Arrays reduziert die Kopiervorgänge auf
    ' ! zwei.

    Private _ReadPixels As Byte(,)
    Private _WritePixels As Byte(,)
    Private _ResultData As New BitmapData

    Private Shared _GrayMatrix As New Imaging.ColorMatrix(New Single()() {New Single() _
        {0.299, 0.299, 0.299, 0, 0}, New Single() {0.587, 0.587, 0.587, 0, 0}, New Single() _
        {0.114, 0.114, 0.114, 0, 0}, New Single() {0, 0, 0, 1, 0}, New Single() {0, 0, 0, 0, _
        1}})

    Private Shared _GrayAttr As New Imaging.ImageAttributes()

    Shared Sub New()

        _GrayAttr.SetColorMatrix(_GrayMatrix)

    End Sub

    Public Sub New( _
              ByVal Img As Image, _
              ByVal Format As Imaging.PixelFormat, _
              Optional ByVal ConvertToGray As Boolean = False)

        With _ResultData
            .Width = Img.Width
            .Height = Img.Height
            _ReadPixels = CreateWritePixels(Format)

            Dim GCH As GCHandle = GCHandle.Alloc(_ReadPixels, GCHandleType.Pinned)

            Using Bmp As New Bitmap(.Width, .Height, .Stride, Format, GCH.AddrOfPinnedObject( _
                )), G As Graphics = Graphics.FromImage(Bmp)

                Dim Rct As New Rectangle(0, 0, .Width, .Height)

                If ConvertToGray Then
                    G.DrawImage(Img, Rct, 0, 0, .Width, .Height, GraphicsUnit.Pixel, _GrayAttr)

                Else

                    G.DrawImageUnscaledAndClipped(Img, Rct)
                End If

            End Using

            GCH.Free()
        End With

    End Sub

    Public ReadOnly Property ReadPixels() As Byte(,)
        Get
            Return _ReadPixels

        End Get

    End Property

    Public Function CreateWritePixels(ByVal Format As Imaging.PixelFormat) As Byte(,)

        With _ResultData
            .PixelFormat = Format
            .Stride = GetStride(.Width, Format)
            ReDim _WritePixels(.Height - 1, .Stride - 1)
        End With

        Return _WritePixels

    End Function

    Public Function GetResultBitmap() As Bitmap

        With _ResultData

            Dim GCH As GCHandle = GCHandle.Alloc(_WritePixels, GCHandleType.Pinned)

            .Scan0 = GCH.AddrOfPinnedObject

            Dim Bmp As New Bitmap(.Width, .Height, .PixelFormat)

            Bmp.LockBits(New Rectangle(0, 0, .Width, .Height), ImageLockMode.WriteOnly Or _
                ImageLockMode.UserInputBuffer, .PixelFormat, _ResultData)

            ' UnlockBits() kopiert _ResultData in die Bitmap
            Bmp.UnlockBits(_ResultData)
            GCH.Free()
            Return Bmp
        End With

    End Function

    ''' <summary>konvertiert ein Image ins angegebene Pixelformat</summary>
    Public Shared Function Convert(ByVal Img As Image, ByVal Format As Imaging.PixelFormat) _
        As Bitmap

        With Img

            Dim Bmp As New Bitmap(.Width, .Height, Format)

            Using G As Graphics = Graphics.FromImage(Bmp)
                G.DrawImageUnscaledAndClipped(Img, New Rectangle(0, 0, .Width, .Height))
            End Using

            Return Bmp
        End With

    End Function

    Public Shared Function GetStride(ByVal Width As Integer, ByVal PixelFormat As _
        Imaging.PixelFormat) As Integer

        ' Aus Namen der Imaging.PixelFormat-Enumeration wie "Format16bppGrayScale" kann man die
        ' ! PixelSize (16bpp) direkt ausparsen
        Dim Name As String = EnumGetName(PixelFormat)
        Dim Indx As Integer = Name.IndexOf("b"c)

        If Indx < 0 Then Throw New Exception(String.Concat("Kann aus dem PixelFormat '", _
            PixelFormat, "' keine PixelSize (bpp) ermitteln.", "Wählen Sie ein " & _
            "System.Drawing.Imaging.PixelFormat, dass diese Angabe im Namen enthält"))

        If Indx > 0 Then

            Dim _PixelSize As Integer = Integer.Parse(Name.Substring(6, Indx - 6))

            ' Format-unabhängig vergrößert eine Bildzeile (Stride) sich immer in 4-Byte-Schritten
            Return ((Width * _PixelSize + 31) And Not 31) \ 8
        End If

    End Function

End Class

' ---------------- Ende Datei PixelHelper.vb  ----------------
' -------- Ende Projektdatei ConVolutionFilter.vbproj --------
' --------- Ende Projektgruppe ConVolutionFilter.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.
Folgende Diskussionen existieren bereits

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