Unicodezeichen in eine Zelle einfügen

Farbverteilung einer Bilddatei.

Beispieldatei (Farbverteilung.zip 31 kB)

Irgendwann ist die Frage aufgetaucht, ob es möglich ist, die Daten aus einem Digitalfoto bereitzustellen.

Es soll damit der prozentuale Pilzbefall auf Blattproben ermittelt werden, das heißt, der Anteil der braunen Flecken auf dem Blattgrün ist entscheidend.

Wie man das letztendlich auswertet, sei dahingestellt. Wichtig ist erst einmal, die Daten eines Digitalfotos für die Auswertung verfügbar zu machen Und genau das macht der nachfolgende Code.

In einem Dialog wird man aufgefordert, eine Bilddatei auszuwählen, deren Daten ausgelesen und bereitgestellt werden. Die zurückgelieferte Collection enthält ein dreidimensionales Array mit dem Schlüsselnamen "AllPixel".
Die erste Dimension gibt die Spalte an.
Die zweite Dimension gibt die Zeile an.
Die dritte Dimension gibt den Farbanteil an. Eins ist dabei der Rotanteil, zwei der Grünanteil und drei der Blauanteil.
Das heißt, myCollection("AllPixel")(1,2,3) würde den Blauanteil des Pixels in der ersten Spalte und der zweiten Zeile liefern.

Außerdem werden noch andere Infos zum Bild bereitgestellt. Der Schlüsselname der Informationscollection ist "Infos". In der Infos-Collection sind die eigentlichen Informationen unter verschiedenen Namen verfügbar.
Das Item "Breite" liefert die Breite , das Item "Höhe" die Höhe des Bildes. Gleichzeitig wurden alle Farbwerte der entsprechenden Grundfarbe des gesamten Bildes addiert. Das heißt, die Summen der Rot- Grün- und Blauanteile eines jedes Pixels wurden in einer Schleife gebildet und werden unter den Schlüsselnamen "Summe R", "Summe G", "Summe B" bereitgestellt.

Im folgenden Bild sieht man die Farbverteilung eines grünen Bildes (mit einem kleinen Blauanteil) mit 300x300 Pixel, das mit einer anderen Farbe verunreinigt wird. Der Anteil der braunen Flecken liegt je nach Bild zwischen 0 und 5%.

Die Bilder können Sie zum Herunterladen anklicken.

Am Ende finden Sie noch Code, wie man ein Bild in verschiedene Einzelbilder aufteilen kann und diese analysieren kann.

Hier der Code zur Analyse eines Bildes:

Option Explicit
Private Declare Function GetDIBits _
   Lib "gdi32" ( _
   ByVal aHDC As Long, _
   ByVal hBM As Long, _
   ByVal nStartSL As Long, _
   ByVal nNumSL As Long, _
   lpBits As Any, _
   lpBI As Any, _
   ByVal wUsage As Long _
   ) As Long
Private Declare Function GetDC _
   Lib "user32" ( _
   ByVal hwnd As Long _
   ) As Long
Private Declare Function ReleaseDC _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   ByVal hdc As Long _
   ) As Long
Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Private Sub test1()
Dim varPixelarray As Collection
Dim strSource     As String

   strSource = Application.GetOpenFilename( _
      "Pic Files (*.jpg;*.jpeg;*.bmp), *.jpg;*.jpeg;*.bmp" _
      )
   If LCase(strSource) = "false" Or _
      LCase(strSource) = "falsch" Then Exit Sub

   Set varPixelarray = ColFromPic( _
      LoadPicture(strSource))

   MsgBox "Red = " & varPixelarray("Infos")("Summe R") & vbCrLf & _
      "Green = " & varPixelarray("Infos")("Summe G") & vbCrLf & _
      "Blue = " & varPixelarray("Infos")("Summe B") & vbCrLf & _
      "Breite = " & varPixelarray("Infos")("Breite") & vbCrLf & _
      "Höhe = " & varPixelarray("Infos")("Höhe") & _
      vbCrLf & _
      "Pixel 1,1 Rot = " & varPixelarray("AllPixel")(1, 1, 1) & _
      vbCrLf & _
      "Pixel 1,1 Grün = " & varPixelarray("AllPixel")(1, 1, 2) & _
      vbCrLf & _
      "Pixel 1,1 Blau = " & varPixelarray("AllPixel")(1, 1, 3)


End Sub

Public Function ColFromPic( _
   ByVal lngPic As Long _
   ) As Collection
Dim audtRGB()                 As RGBQUAD
Dim alngStrukturen(1 To 10)   As Long
Dim abytPixel()               As Byte
Dim lngDC                     As Long
Dim i                         As Long
Dim k                         As Long
Dim curSumR                   As Currency
Dim curSumG                   As Currency
Dim curSumB                   As Currency
Dim colResult                 As New Collection
Dim colSummary                As New Collection

   ' ScreenDC ausleihen
   lngDC = GetDC(0)

   '  Lange der Strukturen
   alngStrukturen(1) = 40

   'Dimensionen ermitteln
   GetDIBits lngDC, lngPic, 0, 0, ByVal 0&, alngStrukturen(1), 0

   alngStrukturen(4) = &H200001

   ' Planes
   alngStrukturen(5) = 0

   ' Puffer bereitstellen
   ReDim audtRGB(alngStrukturen(2) - 1, alngStrukturen(3) - 1)

   ' Warum auch immer, die negative Auzahl Scanzeilen
   alngStrukturen(3) = alngStrukturen(3) * -1

   '  Array füllen
   GetDIBits lngDC, lngPic, 0, -alngStrukturen(3), _
      audtRGB(0, 0), alngStrukturen(1), 0

   ' DC zurückgeben
   ReleaseDC 0, lngDC

   ' Rückgabearray vorbereiten
   ReDim abytPixel( _
      1 To UBound(audtRGB, 1) + 1, _
      1 To UBound(audtRGB, 2) + 1, _
      1 To 3)

   ' Alle Pixel durchlaufen
   For i = 0 To UBound(audtRGB, 1)
      For k = 0 To UBound(audtRGB, 2)
         With audtRGB(i, k)

            abytPixel(i + 1, k + 1, 1) = .rgbRed
            abytPixel(i + 1, k + 1, 2) = .rgbGreen
            abytPixel(i + 1, k + 1, 3) = .rgbBlue

            curSumR = curSumR + .rgbRed
            curSumG = curSumG + .rgbGreen
            curSumB = curSumB + .rgbBlue

         End With
      Next k
   Next i

   ' Infos in eine Collection
   colSummary.Add curSumR, "Summe R"
   colSummary.Add curSumG, "Summe G"
   colSummary.Add curSumB, "Summe B"
   colSummary.Add UBound(audtRGB, 1) + 1, "Breite"
   colSummary.Add UBound(audtRGB, 2) + 1, "Höhe"

   ' Rückgabecollection vorbereiten
   colResult.Add colSummary, "Infos"
   colResult.Add abytPixel, "AllPixel"

   ' Zurückgeben
   Set ColFromPic = colResult

End Function

Hier der Code zum Aufsplitten eines Bildes:

Option Explicit
Private Declare Function DeleteObject _
   Lib "gdi32" ( _
   ByVal hObject As Long _
   ) As Long
Private Declare Function CreateCompatibleBitmap _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal nWidth As Long, _
   ByVal nHeight As Long _
   ) As Long
Private Declare Function CreateCompatibleDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function SelectObject _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal hObject As Long _
   ) As Long
Private Declare Function BitBlt _
   Lib "gdi32" ( _
   ByVal hDestDC As Long, _
   ByVal x As Long, ByVal y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, _
   ByVal hSrcDC As Long, _
   ByVal xSrc As Long, ByVal ySrc As Long, _
   ByVal dwRop As Long _
   ) As Long
Private Declare Function DeleteDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long

Private Const SRCCOPY = &HCC0020

Private Sub Teilen()
Dim lngDC1 As Long
Dim lngDC2 As Long

Dim objPic1 As StdPicture
Dim lngBMPOld1 As Long
Dim lngBMPOld2 As Long
Dim P2BIT As Long
Dim varPixelarray As Collection

   ' DC erstellen, der Kompatibel zum Screen ist
   lngDC1 = CreateCompatibleDC(0&)
   ' StdPicture-Objekt anlegen
   ' Quellbild ist 300 x 300 Pixel
   Set objPic1 = LoadPicture("C:\GrünBraun3%.jpg")
   ' Bild in den DC stellen
   lngBMPOld1 = SelectObject(lngDC1, objPic1)


   ' Bitmap anlegen von 100 x 100 Pixel
   P2BIT = CreateCompatibleBitmap(lngDC1, 100, 100)
   ' DC erstellen, der Kompatibel zum Screen ist
   lngDC2 = CreateCompatibleDC(0&)
   ' Neu angelegte Bitmap in den neuen DC stellen
   lngBMPOld2 = SelectObject(lngDC2, P2BIT)

   ' Ausschnitt von Position 0,0 in der Größe 100 x 100
   ' in das Ziel kopieren (SRCCOPY) an Position 0,0
   ' Die Position beginnt links oben mit 0,0 und wird nach
   ' rechts und unten größer.
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 0, 0, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 2, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 100,0 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 100, 0, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 3, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 200,0 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 200, 0, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 4, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 0,100 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 0, 100, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 5, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 0,200 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 0, 200, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 6, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 100,100 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 100, 100, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 7, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 100,200 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 100, 200, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 8, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 200,100 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 200, 100, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 9, 30, varPixelarray("Infos")

   ' Ausschnitt von Position 200,200 in der Größe 100 x 100
   ' in das Ziel kopieren
   BitBlt lngDC2, 0, 0, 100, 100, lngDC1, 200, 200, SRCCOPY
   Set varPixelarray = ColFromPic(P2BIT)
   Eintragen "Farbverteilung", 10, 30, varPixelarray("Infos")



   ' Originale Bitmap in den DC stellen
   SelectObject lngDC1, lngBMPOld1
   SelectObject lngDC2, lngBMPOld2
   ' Angelegte DC löschen
   DeleteDC lngDC2
   DeleteDC lngDC1
   ' Angelegte Bitmap löschen
   DeleteObject P2BIT


End Sub

Public Sub Eintragen( _
   strTabelle As String, _
   lngZielspalte As Long, _
   lngZielzeile As Long, _
   colInfo As Collection)

Dim dblEinProzent As Double
On Error GoTo Fehlerbehandlung

With Worksheets(strTabelle)

   .Cells(lngZielzeile, lngZielspalte).Value = colInfo("Breite")
   .Cells(lngZielzeile + 1, lngZielspalte).Value = colInfo("Höhe")

   .Cells(lngZielzeile + 2, lngZielspalte).Value = _
      CDec(colInfo("Summe R"))
   .Cells(lngZielzeile + 3, lngZielspalte).Value = _
      CDec(colInfo("Summe G"))
   .Cells(lngZielzeile + 4, lngZielspalte).Value = _
      CDec(colInfo("Summe B"))

   dblEinProzent = colInfo("Summe R") + _
      colInfo("Summe G") + _
      colInfo("Summe B")
   dblEinProzent = dblEinProzent / 100

   .Cells(lngZielzeile + 5, lngZielspalte).Value = _
      CDbl(colInfo("Summe R")) / dblEinProzent
   .Cells(lngZielzeile + 6, lngZielspalte).Value = _
      CDbl(colInfo("Summe G")) / dblEinProzent
   .Cells(lngZielzeile + 7, lngZielspalte).Value = _
      CDbl(colInfo("Summe B")) / dblEinProzent

End With

Exit Sub
Fehlerbehandlung:
MsgBox "Fehler beim Eintragen in Tabellenblatt"
End Sub