Um festzustellen, ob zwei Bilddateien das (exakt) gleiche Bild enthalten, kann man die Bilder in Bitmap-Objekte laden und einen Pixelvergleich durchführen. Zu beachten ist dabei, dass jede Bildbearbeitung (Komprimierung, Formatierung, Aufhellung o.ä.) die Bildpixel ändert - selbst wenn für das Auge die Bilder noch identisch erscheinen. VB 2008 Um die Erweiterungsmethode 'IsEqual' für das Bitmap-Objekt verwenden zu können, ist nur das Modul dem Projekt hinzuzufügen (ab VB 2008). Aufrufbeispiel: With My.Computer.FileSystem.SpecialDirectories Dim pic1 As New Drawing.Bitmap(.MyPictures & "\pic1.jpg") Dim pic2 As New Drawing.Bitmap(.MyPictures & "\pic2.jpg") If pic1.IsEqual(pic2) Then MsgBox("Die Bildpixel sind identisch") Else MsgBox("Die Bildpixel sind NICHT identisch") End If End With Option Strict On Option Explicit On Option Infer Off Imports System Imports System.Drawing ' Bitmap / Rectangle Imports System.Drawing.Imaging ' BitmapData / ImageLockMode Imports System.Runtime ' CompilerServices / InterOpServices Module modBitMapsEqual ''' <summary> ''' Ist in beiden Bitmap-Objekten das gleiche Bild enthalten? ''' (Kriterium: Alle Pixelwerte sind identisch)</summary> ''' <param name="bmp1">Erste Bitmap für Vergleich</param> ''' <param name="bmp2">Zweite Bitmap für Vergleich</param> ''' <returns>True, falls gleiches Bild, sonst False</returns> <CompilerServices.Extension()> _ Public Function IsEqual(ByVal bmp1 As Bitmap, ByVal bmp2 As Bitmap) As Boolean Dim equal As Boolean = True ' für Pixelvergleich ' Sind zwei Bilder vorhanden? If bmp1 Is Nothing Or bmp2 Is Nothing Then Return False ' Gleiche Klassen-Instanz ---> gleiches Bild If Bitmap.ReferenceEquals(bmp1, bmp2) Then Return True ' Ungleiche Größe/Farbtiefe --> ungleiches Bild With bmp1 If .Width <> bmp2.Width Then Return False If .Height <> bmp2.Height Then Return False If .PixelFormat <> bmp2.PixelFormat Then Return False End With ' Bei beiden Bitmaps alle Bild-Daten im Speicher sperren Dim rect As New Rectangle(0, 0, bmp1.Width, bmp1.Height) Dim bd1 As BitmapData = bmp1.LockBits(rect, ImageLockMode.ReadOnly, bmp1.PixelFormat) Dim bd2 As BitmapData = bmp2.LockBits(rect, ImageLockMode.ReadOnly, bmp2.PixelFormat) ' Gesamtzahl der Bild-Bytes per Scanbreite & Bildhöhe ermitteln Dim ByteZahl As Integer = bd1.Stride * bd1.Height ' Bitmap-Daten besorgen (Bytearray) Dim bmp1_bytes(ByteZahl - 1), bmp2_bytes(ByteZahl - 1) As Byte ' Die gesperrten Bilddaten in 2 Bytearrays kopieren InteropServices.Marshal.Copy(bd1.Scan0, bmp1_bytes, 0, ByteZahl) InteropServices.Marshal.Copy(bd2.Scan0, bmp2_bytes, 0, ByteZahl) ' Bitmap-Daten vergleichen For i As Integer = 0 To ByteZahl - 1 If bmp1_bytes(i) <> bmp2_bytes(i) Then equal = False : Exit For End If Next i ' Daten und Ressourcen freigeben bmp1.UnlockBits(bd1) : bmp2.UnlockBits(bd2) ' Rückgabe Return equal End Function End Module VB 2005 Unter VB2005 werden Erweiterungsmethoden (Extensions) noch nicht unterstützt. Jedoch lässt sich obiger Code sehr einfach anpassen und somit auch unter VB2005 einsetzen. Änderungen am Modul "modBitMapEqual" Option Strict On Option Explicit On Imports System Imports System.Drawing ' Bitmap / Rectangle Imports System.Drawing.Imaging ' BitmapData / ImageLockMode Imports System.Runtime ' CompilerServices / InterOpServices Module modBitMapsEqual ''' <summary> ''' Ist in beiden Bitmap-Objekten das gleiche Bild enthalten? ''' (Kriterium: Alle Pixelwerte sind identisch)</summary> ''' <param name="bmp1">Erste Bitmap für Vergleich</param> ''' <param name="bmp2">Zweite Bitmap für Vergleich</param> ''' <returns>True, falls gleiches Bild, sonst False</returns> Public Function BmpIsEqual(ByVal bmp1 As Bitmap, ByVal bmp2 As Bitmap) As Boolean ... Aufrufbeispiel: With My.Computer.FileSystem.SpecialDirectories Dim pic1 As New Drawing.Bitmap(.MyPictures & "\pic1.jpg") Dim pic2 As New Drawing.Bitmap(.MyPictures & "\pic2.jpg") If BmpIsEqual(pic1, pic2) Then MsgBox("Die Bildpixel sind identisch") Else MsgBox("Die Bildpixel sind NICHT identisch") End If End With Dieser Tipp wurde bereits 14.719 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
Neu! sevEingabe 3.0 Einfach stark! Ein einziges Eingabe-Control für alle benötigten Eingabetypen und -formate, inkl. Kalender-, Taschenrechner und Floskelfunktion, mehrspaltige ComboBox mit DB-Anbindung, ImageComboBox u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Access-Tools Vol.1 Über 400 MByte Inhalt Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |