Bild in einer Picturebox perspektivisch darstellen Während der Runtime wird mit Hilfe von 3 Klassen eine Picturebox in eine perspektivische oder verzerrte Darstellung transformiert.
Autor:   Dietrich Herrmann	Bewertung:     [ Jetzt bewerten ]	Views:  13.417
ohne Homepage	System:  Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 11 Bewertung insgesamt: gut Durchschnittliche Bewertung: 4.1 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Beim Suchen nach einer Lösung zu oben genanntem Sachverhalt stieß ich im Internet auf folgenden Link:
 http://www.codeproject.com/KB/graphics/YLScsFreeTransform.aspx

Ich habe dann die benötigten Klassen aus C# in VB übersetzt und stelle sie hier in diesem Tipp inklusive eines Anwendungsbeispiels zur Verfügung.

Erzeuge ein Projekt mit den unten stehenden drei Klassen.
Zum Ausprobieren erstelle eine neue Form, gib ihr ein Hintergrundbild. Dann erstelle zwei Pictureboxen auf dieser Form und versehe sie jeweils mit einem Bild.

Ins Form_Load-Ereignis schreibe folgenden Code:

Dim kh, kv As Integer
Dim srcBmp As Bitmap = PictureBox1.Image
Dim perspective As New YLScsDrawing.Imaging.Filters.FreeTransform()
 
With perspective
  .Bitmap = srcBmp
  .IsBilinearInterpolation = True
  With PictureBox1
    kv = .Height / 4 : kh = .Width / 2
    perspective.FourCorners = New PointF() {New Point(0, 0), _
      New Point(.Width - kh, kv), _
      New Point(.Width - kh, .Height - kv), _
      New Point(0, .Height)}
  End With
  PictureBox1.Image = .Bitmap
End With
 
srcBmp = PictureBox2.Image
With perspective
  .Bitmap = srcBmp
  .IsBilinearInterpolation = True
  With PictureBox2
    kv = .Height / 4 : kh = .Width / 4
    perspective.FourCorners = New PointF() {New Point(kh, kv), _
      New Point(.Width - kh, 0), _
      New Point(.Width - kh, .Height), _
      New Point(kh, .Height - kv)}
  End With
  PictureBox2.Image = .Bitmap
End With

Dieser Code erzeugt die perspektivischen Darstellungen der Pictures; man kann mit den Werten für die vier Ecken ein bisschen herum experimentieren...

Und hier der Code für die drei benötigten Klassen:

Imports System
Imports System.Drawing
Imports System.Drawing.Drawing2D
 
Namespace YLScsDrawing.Imaging.Filters
  Public Class FreeTransform
    Private vertex As PointF() = New PointF(3) {}
    Private AB As YLScsDrawing.Geometry.Vector, _
            BC As YLScsDrawing.Geometry.Vector, _
            CD As YLScsDrawing.Geometry.Vector, _
            DA As YLScsDrawing.Geometry.Vector
    Private rect As New Rectangle()
    Private srcCB As YLScsDrawing.Imaging.ImageData = New ImageData()
    Private srcW As Integer = 0
    Private srcH As Integer = 0
 
    Public Property Bitmap() As Bitmap
      Get
        Return getTransformedBitmap()
      End Get
      Set(ByVal value As Bitmap)
        Try
          srcCB.FromBitmap(value)
          srcH = value.Height
          srcW = value.Width
        Catch
          srcW = 0
          srcH = 0
        End Try
      End Set
    End Property
 
    Public Property ImageLocation() As Point
      Get
        Return rect.Location
      End Get
      Set(ByVal value As Point)
        rect.Location = value
      End Set
    End Property
 
    Private isBilinear As Boolean = False
    Public Property IsBilinearInterpolation() As Boolean
      Get
        Return isBilinear
      End Get
      Set(ByVal value As Boolean)
        isBilinear = value
      End Set
    End Property
 
    Public ReadOnly Property ImageWidth() As Integer
      Get
        Return rect.Width
      End Get
    End Property
 
    Public ReadOnly Property ImageHeight() As Integer
      Get
        Return rect.Height
      End Get
    End Property
 
    Public Property VertexLeftTop() As PointF
      Get
        Return vertex(0)
      End Get
      Set(ByVal value As PointF)
        vertex(0) = value
        setVertex()
      End Set
    End Property
 
    Public Property VertexTopRight() As PointF
      Get
        Return vertex(1)
      End Get
      Set(ByVal value As PointF)
        vertex(1) = value
        setVertex()
      End Set
    End Property
 
    Public Property VertexRightBottom() As PointF
      Get
        Return vertex(2)
      End Get
      Set(ByVal value As PointF)
        vertex(2) = value
        setVertex()
      End Set
    End Property
 
    Public Property VertexBottomLeft() As PointF
      Get
        Return vertex(3)
      End Get
      Set(ByVal value As PointF)
        vertex(3) = value
        setVertex()
      End Set
    End Property
 
    Public Property FourCorners() As PointF()
      Get
        Return vertex
      End Get
      Set(ByVal value As PointF())
        vertex = value
        setVertex()
      End Set
    End Property
 
    Private Sub setVertex()
      Dim xmin As Single = Single.MaxValue
      Dim ymin As Single = Single.MaxValue
      Dim xmax As Single = Single.MinValue
      Dim ymax As Single = Single.MinValue
 
      For i As Integer = 0 To 3
        xmax = Math.Max(xmax, vertex(i).X)
        ymax = Math.Max(ymax, vertex(i).Y)
        xmin = Math.Min(xmin, vertex(i).X)
        ymin = Math.Min(ymin, vertex(i).Y)
      Next
 
      rect = New Rectangle(CInt(xmin), CInt(ymin), CInt((xmax - xmin)), CInt((ymax - ymin)))
 
      AB = New YLScsDrawing.Geometry.Vector(vertex(0), vertex(1))
      BC = New YLScsDrawing.Geometry.Vector(vertex(1), vertex(2))
      CD = New YLScsDrawing.Geometry.Vector(vertex(2), vertex(3))
      DA = New YLScsDrawing.Geometry.Vector(vertex(3), vertex(0))
 
      ' get unit vector
      AB /= AB.Magnitude
      BC /= BC.Magnitude
      CD /= CD.Magnitude
      DA /= DA.Magnitude
    End Sub
 
    Private Function isOnPlaneABCD(ByVal pt As PointF) As Boolean
      '  including point on border
      If Not YLScsDrawing.Geometry.Vector.IsCCW(pt, vertex(0), vertex(1)) Then
        If Not YLScsDrawing.Geometry.Vector.IsCCW(pt, vertex(1), vertex(2)) Then
          If Not YLScsDrawing.Geometry.Vector.IsCCW(pt, vertex(2), vertex(3)) Then
            If Not YLScsDrawing.Geometry.Vector.IsCCW(pt, vertex(3), vertex(0)) Then
              Return True
            End If
          End If
        End If
      End If
      Return False
    End Function
 
    Private Function getTransformedBitmap() As Bitmap
      If srcH = 0 OrElse srcW = 0 Then Return Nothing
 
      Dim destCB As New ImageData()
      destCB.A = New Byte(rect.Width - 1, rect.Height - 1) {}
      destCB.B = New Byte(rect.Width - 1, rect.Height - 1) {}
      destCB.G = New Byte(rect.Width - 1, rect.Height - 1) {}
      destCB.R = New Byte(rect.Width - 1, rect.Height - 1) {}
 
      Dim ptInPlane As New PointF()
      Dim x1 As Integer, x2 As Integer, y1 As Integer, y2 As Integer
      Dim dab As Double, dbc As Double, dcd As Double, dda As Double
      Dim dx1 As Single, dx2 As Single, dy1 As Single, dy2 As Single, _
          dx1y1 As Single, dx1y2 As Single, _
          dx2y1 As Single, dx2y2 As Single, nbyte As Single
 
      For y As Integer = 0 To rect.Height - 1
        For x As Integer = 0 To rect.Width - 1
          Dim srcPt As New Point(x, y)
          srcPt.Offset(Me.rect.Location)
 
          If isOnPlaneABCD(srcPt) Then
            dab = Math.Abs( _
              (New YLScsDrawing.Geometry.Vector(vertex(0), srcPt)).CrossProduct(AB))
            dbc = Math.Abs( _
              (New YLScsDrawing.Geometry.Vector(vertex(1), srcPt)).CrossProduct(BC))
            dcd = Math.Abs( _
              (New YLScsDrawing.Geometry.Vector(vertex(2), srcPt)).CrossProduct(CD))
            dda = Math.Abs( _
              (New YLScsDrawing.Geometry.Vector(vertex(3), srcPt)).CrossProduct(DA))
            ptInPlane.X = CSng((srcW * (dda / (dda + dbc))))
            ptInPlane.Y = CSng((srcH * (dab / (dab + dcd))))
 
            x1 = CInt(ptInPlane.X)
            y1 = CInt(ptInPlane.Y)
 
            If x1 >= 0 AndAlso x1 < srcW AndAlso y1 >= 0 AndAlso y1 < srcH Then
              If isBilinear Then
                x2 = IIf((x1 = srcW - 1), x1, x1 + 1)
                y2 = IIf((y1 = srcH - 1), y1, y1 + 1)
 
                dx1 = ptInPlane.X - CSng(x1)
                If dx1 < 0 Then dx1 = 0
                dx1 = 1.0F - dx1
                dx2 = 1.0F - dx1
                dy1 = ptInPlane.Y - CSng(y1)
                If dy1 < 0 Then dy1 = 0
                dy1 = 1.0F - dy1
                dy2 = 1.0F - dy1
 
                dx1y1 = dx1 * dy1
                dx1y2 = dx1 * dy2
                dx2y1 = dx2 * dy1
                dx2y2 = dx2 * dy2
 
                nbyte = srcCB.A(x1, y1) * dx1y1 + srcCB.A(x2, y1) _
                    * dx2y1 + srcCB.A(x1, y2) * dx1y2 + srcCB.A(x2, y2) * dx2y2
                destCB.A(x, y) = CByte(nbyte)
                nbyte = srcCB.B(x1, y1) * dx1y1 + srcCB.B(x2, y1) _
                    * dx2y1 + srcCB.B(x1, y2) * dx1y2 + srcCB.B(x2, y2) * dx2y2
                destCB.B(x, y) = CByte(nbyte)
                nbyte = srcCB.G(x1, y1) * dx1y1 + srcCB.G(x2, y1) _
                    * dx2y1 + srcCB.G(x1, y2) * dx1y2 + srcCB.G(x2, y2) * dx2y2
                destCB.G(x, y) = CByte(nbyte)
                nbyte = srcCB.R(x1, y1) * dx1y1 + srcCB.R(x2, y1) _
                    * dx2y1 + srcCB.R(x1, y2) * dx1y2 + srcCB.R(x2, y2) * dx2y2
                destCB.R(x, y) = CByte(nbyte)
              Else
                destCB.A(x, y) = srcCB.A(x1, y1)
                destCB.B(x, y) = srcCB.B(x1, y1)
                destCB.G(x, y) = srcCB.G(x1, y1)
                destCB.R(x, y) = srcCB.R(x1, y1)
              End If
            End If
          End If
        Next
      Next
      Return destCB.ToBitmap()
    End Function
  End Class
End Namespace

Imports System
Imports System.Collections.Generic
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
 
Namespace YLScsDrawing.Imaging
  ''' <summary>
  ''' Using InteropServices.Marshal methods to get image channels (R,G,B,A) byte
  ''' </summary>
  Public Class ImageData
    Implements IDisposable
    Private _red As Byte(,), _green As Byte(,), _blue As Byte(,), _alpha As Byte(,)
    Private _disposed As Boolean = False
 
    Public Property A() As Byte(,)
      Get
        Return _alpha
      End Get
      Set(ByVal value As Byte(,))
        _alpha = value
      End Set
    End Property
    Public Property B() As Byte(,)
      Get
        Return _blue
      End Get
      Set(ByVal value As Byte(,))
        _blue = value
      End Set
    End Property
    Public Property G() As Byte(,)
      Get
        Return _green
      End Get
      Set(ByVal value As Byte(,))
        _green = value
      End Set
    End Property
    Public Property R() As Byte(,)
      Get
        Return _red
      End Get
      Set(ByVal value As Byte(,))
        _red = value
      End Set
    End Property
 
    Public Function Clone() As ImageData
      Dim cb As New ImageData()
      cb.A = DirectCast(_alpha.Clone(), Byte(,))
      cb.B = DirectCast(_blue.Clone(), Byte(,))
      cb.G = DirectCast(_green.Clone(), Byte(,))
      cb.R = DirectCast(_red.Clone(), Byte(,))
      Return cb
    End Function
 
#Region "InteropServices.Marshal methods"
 
    Public Sub FromBitmap(ByVal srcBmp As Bitmap)
      Dim w As Integer = srcBmp.Width
      Dim h As Integer = srcBmp.Height
 
      _alpha = New Byte(w - 1, h - 1) {}
      _blue = New Byte(w - 1, h - 1) {}
      _green = New Byte(w - 1, h - 1) {}
      _red = New Byte(w - 1, h - 1) {}
 
      ' Lock the bitmap's bits.  
      Dim bmpData As BitmapData = srcBmp.LockBits(New Rectangle(0, 0, w, h), _
        ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb)
      ' Get the address of the first line.
      Dim ptr As IntPtr = bmpData.Scan0
 
      ' Declare an array to hold the bytes of the bitmap.
      Dim bytes As Integer = bmpData.Stride * srcBmp.Height
      Dim rgbValues As Byte() = New Byte(bytes - 1) {}
 
      ' Copy the RGB values
      Marshal.Copy(ptr, rgbValues, 0, bytes)
 
      Dim offset As Integer = bmpData.Stride - w * 4
 
      Dim index As Integer = 0
      For y As Integer = 0 To h - 1
        For x As Integer = 0 To w - 1
          _blue(x, y) = rgbValues(index)
          _green(x, y) = rgbValues(index + 1)
          _red(x, y) = rgbValues(index + 2)
          _alpha(x, y) = rgbValues(index + 3)
          index += 4
        Next
        index += offset
      Next
 
      ' Unlock the bits.
      srcBmp.UnlockBits(bmpData)
    End Sub
 
    Public Function ToBitmap() As Bitmap
      Dim width As Integer = 0, height As Integer = 0
      If _alpha IsNot Nothing Then
        width = Math.Max(width, _alpha.GetLength(0))
        height = Math.Max(height, _alpha.GetLength(1))
      End If
      If _blue IsNot Nothing Then
        width = Math.Max(width, _blue.GetLength(0))
        height = Math.Max(height, _blue.GetLength(1))
      End If
      If _green IsNot Nothing Then
        width = Math.Max(width, _green.GetLength(0))
        height = Math.Max(height, _green.GetLength(1))
      End If
      If _red IsNot Nothing Then
        width = Math.Max(width, _red.GetLength(0))
        height = Math.Max(height, _red.GetLength(1))
      End If
      Dim bmp As New Bitmap(width, height, PixelFormat.Format32bppArgb)
      Dim bmpData As BitmapData = bmp.LockBits(New Rectangle(0, 0, width, height), _
        ImageLockMode.ReadWrite, PixelFormat.Format32bppArgb)
 
      ' Get the address of the first line.
      Dim ptr As IntPtr = bmpData.Scan0
 
      ' Declare an array to hold the bytes of the bitmap.
      Dim bytes As Integer = bmpData.Stride * bmp.Height
      Dim rgbValues As Byte() = New Byte(bytes - 1) {}
 
      ' set rgbValues
      Dim offset As Integer = bmpData.Stride - width * 4
      Dim i As Integer = 0
      For y As Integer = 0 To height - 1
        For x As Integer = 0 To width - 1
          rgbValues(i) = IIf(checkArray(_blue, x, y), _blue(x, y), CByte(0))
          rgbValues(i + 1) = IIf(checkArray(_green, x, y), _green(x, y), CByte(0))
          rgbValues(i + 2) = IIf(checkArray(_red, x, y), _red(x, y), CByte(0))
          rgbValues(i + 3) = IIf(checkArray(_alpha, x, y), _alpha(x, y), CByte(255))
          i += 4
        Next
        i += offset
      Next
 
      ' Copy the RGB values back to the bitmap
      Marshal.Copy(rgbValues, 0, ptr, bytes)
 
      ' Unlock the bits.
      bmp.UnlockBits(bmpData)
      Return bmp
    End Function
#End Region
 
    Private Shared Function checkArray(ByVal array As Byte(,), _
      ByVal x As Integer, ByVal y As Integer) As Boolean
 
      If array Is Nothing Then
        Return False
      End If
      If x < array.GetLength(0) AndAlso y < array.GetLength(1) Then
        Return True
      Else
        Return False
      End If
    End Function
 
    Public Overloads Sub Dispose() Implements IDisposable.Dispose
      Dispose(True)
      ' Use SupressFinalize in case a subclass
      ' of this type implements a finalizer.
      GC.SuppressFinalize(Me)
    End Sub
 
    Protected Overloads Sub Dispose(ByVal disposing As Boolean)
      ' If you need thread safety, use a lock around these 
      ' operations, as well as in your methods that use the resource.
      If Not _disposed Then
        If disposing Then
          _alpha = Nothing
          _blue = Nothing
          _green = Nothing
          _red = Nothing
        End If
 
        ' Indicate that the instance has been disposed.
        _disposed = True
      End If
    End Sub
  End Class
End Namespace

Imports System
Imports System.Drawing
 
Namespace YLScsDrawing.Geometry
  Public Structure Vector
    Private _x As Double, _y As Double
 
    Public Sub New(ByVal x As Double, ByVal y As Double)
      _x = x
      _y = y
    End Sub
    Public Sub New(ByVal pt As PointF)
      _x = pt.X
      _y = pt.Y
    End Sub
    Public Sub New(ByVal st As PointF, ByVal [end] As PointF)
      _x = [end].X - st.X
      _y = [end].Y - st.Y
    End Sub
 
    Public Property X() As Double
      Get
        Return _x
      End Get
      Set(ByVal value As Double)
        _x = value
      End Set
    End Property
 
    Public Property Y() As Double
      Get
        Return _y
      End Get
      Set(ByVal value As Double)
        _y = value
      End Set
    End Property
 
    Public ReadOnly Property Magnitude() As Double
      Get
        Return Math.Sqrt(X * X + Y * Y)
      End Get
    End Property
 
    Public Shared Operator +(ByVal v1 As Vector, ByVal v2 As Vector) As Vector
      Return New Vector(v1.X + v2.X, v1.Y + v2.Y)
    End Operator
 
    Public Shared Operator -(ByVal v1 As Vector, ByVal v2 As Vector) As Vector
      Return New Vector(v1.X - v2.X, v1.Y - v2.Y)
    End Operator
 
    Public Shared Operator -(ByVal v As Vector) As Vector
      Return New Vector(-v.X, -v.Y)
    End Operator
 
    Public Shared Operator *(ByVal c As Double, ByVal v As Vector) As Vector
      Return New Vector(c * v.X, c * v.Y)
    End Operator
 
    Public Shared Operator *(ByVal v As Vector, ByVal c As Double) As Vector
      Return New Vector(c * v.X, c * v.Y)
    End Operator
 
    Public Shared Operator /(ByVal v As Vector, ByVal c As Double) As Vector
      Return New Vector(v.X / c, v.Y / c)
    End Operator
 
    ' A * B =|A|.|B|.sin(angle AOB)
    Public Function CrossProduct(ByVal v As Vector) As Double
      Return _x * v.Y - v.X * _y
    End Function
 
    ' A. B=|A|.|B|.cos(angle AOB)
    Public Function DotProduct(ByVal v As Vector) As Double
      Return _x * v.X + _y * v.Y
    End Function
 
    Public Shared Function IsClockwise(ByVal pt1 As PointF, _
      ByVal pt2 As PointF, ByVal pt3 As PointF) As Boolean
 
      Dim V21 As New Vector(pt2, pt1)
      Dim v23 As New Vector(pt2, pt3)
      ' sin(angle pt1 pt2 pt3) > 0, 0<angle pt1 pt2 pt3 <180
      Return V21.CrossProduct(v23) < 0
    End Function
 
    Public Shared Function IsCCW(ByVal pt1 As PointF, _
      ByVal pt2 As PointF, ByVal pt3 As PointF) As Boolean
 
      Dim V21 As New Vector(pt2, pt1)
      Dim v23 As New Vector(pt2, pt3)
      ' sin(angle pt2 pt1 pt3) < 0, 180<angle pt2 pt1 pt3 <360
      Return V21.CrossProduct(v23) > 0
    End Function
 
    Public Shared Function DistancePointLine(ByVal pt As PointF, _
      ByVal lnA As PointF, ByVal lnB As PointF) As Double
 
      Dim v1 As New Vector(lnA, lnB)
      Dim v2 As New Vector(lnA, pt)
      v1 /= v1.Magnitude
      Return Math.Abs(v2.CrossProduct(v1))
    End Function
 
    Public Sub Rotate(ByVal Degree As Integer)
      Dim radian As Double = Degree * Math.PI / 180.0R
      Dim sin As Double = Math.Sin(radian)
      Dim cos As Double = Math.Cos(radian)
      Dim nx As Double = _x * cos - _y * sin
      Dim ny As Double = _x * sin + _y * cos
      _x = nx
      _y = ny
    End Sub
 
    Public Function ToPointF() As PointF
      Return New PointF(CSng(_x), CSng(_y))
    End Function
  End Structure
End Namespace

Und nun viel Spaß damit!