Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0723: Bilder mit Toleranz vergleichen

VB 5/6-Tipp 0723: Bilder mit Toleranz vergleichen

 von Danielo

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA (CallWindowProc), CreateDIBSection, DeleteObject, GetDC, GetDIBits, GetObjectA (GetObject), GetTickCount, ReleaseDC, RtlMoveMemory

Download: Download des Beispielprojektes [17,6 KB]

'Dieser Quellcode 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!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "cmdClear"
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Optionsfeld-Steuerelement "optNoMark" auf Frame1
' Steuerelement: Optionsfeld-Steuerelement "optMarkMatches" auf Frame1
' Steuerelement: Optionsfeld-Steuerelement "optMarkChanges" auf Frame1
' Steuerelement: Schaltfläche "cmdBenchmark"
' Steuerelement: Kontrollkästchen-Steuerelement "chkGrid"
' Steuerelement: Horizontale Scrollbar "scrThreshold"
' Steuerelement: Horizontale Scrollbar "scrSpotsize"
' Steuerelement: Schaltfläche "cmdCompare"
' Steuerelement: Bildfeld-Steuerelement "picB"
' Steuerelement: Bildfeld-Steuerelement "picA"
' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Beschriftungsfeld "lblThreshold"
' Steuerelement: Beschriftungsfeld "lblSpotsize"
'************************************************************************
'*               Compare Bitmaps fast via asm with Threshold            *
'*                           by Daniel Aue 03.2004                      *
'*                                                                      *
'*                     USE ENTIRELY AT YOUR OWN RISK.                   *
'*                 you may publish this source as long as               *
'*                      this commentblock stays in                      *
'************************************************************************

Option Explicit

Dim bMouseHold As Boolean

Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Private Sub cmdBenchmark_Click()
   Dim Ticks As Long
   Dim fps As Long
   Dim X As Integer
   
   Me.MousePointer = vbHourglass
   Ticks = GetTickCount
   For X = 0 To 100
      DoASMCompare Me.picA.Picture, Me.picB.Picture, Me.scrSpotsize.Value, Me.scrThreshold.Value
   Next
   Ticks = GetTickCount - Ticks
   Me.MousePointer = vbDefault
   fps = 1000 / (Ticks / 100)
   MsgBox fps & " Frames per Second"
End Sub

Private Sub cmdClear_Click()
    Me.picB.Cls
End Sub

Private Sub cmdCompare_Click()
    Dim Percent As Double
    Form1.picB.DrawWidth = 1
    If optMarkChanges Then
        Percent = DoASMCompare(Me.picA.Image, Me.picB.Image, Me.scrSpotsize.Value, _
            Me.scrThreshold.Value, AddressOf CallbackFunc)
    ElseIf optMarkMatches Then
        Percent = DoASMCompare(Me.picA.Image, Me.picB.Image, Me.scrSpotsize.Value, _
            Me.scrThreshold.Value, AddressOf CallbackFunc, True)
    Else
        Percent = DoASMCompare(Me.picA.Image, Me.picB.Image, Me.scrSpotsize.Value, _
            Me.scrThreshold.Value)
    End If
   
    MsgBox Round(Percent, 2) & "%"
End Sub

Private Sub Form_Load()
    Me.scrSpotsize.Min = 1
    Me.scrSpotsize.Max = Me.picA.ScaleWidth
    Me.scrSpotsize.Value = 10
    
    Me.scrThreshold.Min = 0
    Me.scrThreshold.Max = 255
    Me.scrThreshold = 16
End Sub





Private Sub picB_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    bMouseHold = True
    picB.DrawWidth = 5
    picB.PSet (X, Y)
End Sub


Private Sub picB_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If bMouseHold Then
        picB.PSet (X, Y)
    End If
End Sub

Private Sub picB_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    bMouseHold = False
End Sub

Private Sub scrSpotsize_Change()
    Me.lblSpotsize = "Spotsize: " & Me.scrSpotsize.Value
    If Me.chkGrid Then
        DrawGrid
    End If
End Sub

Private Sub scrSpotsize_Scroll()
    scrSpotsize_Change
End Sub

Private Sub scrThreshold_Change()
    Me.lblThreshold = "Threshold: " & Hex(Me.scrThreshold.Value)
End Sub

Private Sub scrThreshold_Scroll()
    scrThreshold_Change
End Sub


Private Sub chkGrid_Click()
    If Me.chkGrid Then
        DrawGrid
        MsgBox "Der angezeigte Raster wird beim Vergleich " & _
            "gegebenenfalls als Unterschied ausgewertet. " & _
            "Das ist dann der Fall, wenn die weißen Pixel " & _
            "des Rasters den Mittelwert eines Spots soweit " & _
            "'verändern', dass der Unterschied über dem eingestellten " & _
            "Threshold liegt.", vbInformation, "Information:"
    Else
        Me.picB.Cls
    End If
End Sub


Private Sub DrawGrid()
    Dim X As Integer
    Dim Y As Integer
    
    Me.picB.Cls
    Me.picB.DrawWidth = 1
    'Grid geht von unten aus, da Bitmap upside down im Speicher liegt
    Y = Me.picB.ScaleHeight
    For X = 0 To Me.picB.ScaleWidth Step Me.scrSpotsize.Value
       picB.Line (X, 0)-(X, Me.picB.ScaleHeight), &HFFFFFF
       picB.Line (0, Y)-(Me.picB.ScaleWidth, Y), &HFFFFFF
       Y = Y - Me.scrSpotsize.Value
    Next
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--- Anfang Modul "modPicCompare" alias modPicCompare.bas ---
Option Explicit

Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" ( _
        ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" _
        (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
     
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" _
        (ByVal hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)

Private Declare Function CreateDIBSection Lib "gdi32.dll" ( _
        ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, _
        ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal aHDC As Long, ByVal hBitmap As Long, _
        ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Long, _
        lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, _
        ByVal hdc As Long) As Long

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0




Function DoASMCompare(PictureA As StdPicture, PictureB As StdPicture, _
      ByVal Spotsize As Integer, ByVal RGBThreshold As Byte, _
      Optional lpCallbackFunction As Long = 0, _
      Optional CallbackOnEqualSpots As Boolean = False) As Double
'************************************************************************
'*               Compare Bitmaps fast via asm with Threshold            *
'*                           by Daniel Aue 03.2004                      *
'*                                                                      *
'*                     USE ENTIRELY AT YOUR OWN RISK.                   *
'*                 you may publish this source as long as               *
'*                      this commentblock stays in                      *
'************************************************************************
   Dim hDibA As Long
   Dim lpDataA As Long
   Dim udtBmpInfoA As BITMAPINFO
   Dim hDibB As Long
   Dim lpDataB As Long
   Dim udtBmpInfoB As BITMAPINFO
   
   Dim nTotalSpots As Long
   Dim nResult As Long
   Dim nTemp As Long
   
   lpDataA = GetBitmapData(PictureA, hDibA, udtBmpInfoA, False)
   lpDataB = GetBitmapData(PictureB, hDibB, udtBmpInfoB, False)
  
   'some checks:
   If udtBmpInfoA.bmiHeader.biWidth <> udtBmpInfoB.bmiHeader.biWidth Or _
      udtBmpInfoA.bmiHeader.biHeight <> udtBmpInfoB.bmiHeader.biHeight Then
      Err.Raise 513, , "DoASMCompare: Nur gleich grosse Bilder können verglichen werden!"
   End If
   If Spotsize = 0 Then
      Err.Raise 513, , "DoASMCompare: Ungültige Parameter für Spotsize!"
   End If
       
   'total number of spots:
   nTotalSpots = Int(udtBmpInfoA.bmiHeader.biWidth / Spotsize)
   If udtBmpInfoA.bmiHeader.biWidth Mod Spotsize > 0 Then
      nTotalSpots = nTotalSpots + 1
   End If
   If udtBmpInfoA.bmiHeader.biHeight Mod Spotsize > 0 Then
      nTotalSpots = nTotalSpots * (Int(udtBmpInfoA.bmiHeader.biHeight / Spotsize) + 1)
   Else
      nTotalSpots = nTotalSpots * (Int(udtBmpInfoA.bmiHeader.biHeight / Spotsize))
   End If
   
  
   'initialize the Parameter Struct for the Asm Call:
   Dim AsmPara(14) As Long
   AsmPara(0) = lpDataA
   AsmPara(1) = lpDataB
   AsmPara(2) = udtBmpInfoA.bmiHeader.biHeight
   AsmPara(3) = udtBmpInfoA.bmiHeader.biWidth
   AsmPara(4) = ((udtBmpInfoA.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC)
   AsmPara(5) = Spotsize
   AsmPara(6) = RGBThreshold
   AsmPara(7) = lpCallbackFunction
   AsmPara(8) = 0 'reserved
   AsmPara(9) = 0 'reserved
   AsmPara(10) = 0 'reserved
   AsmPara(11) = 0 'reserved
   AsmPara(12) = 0 'reserved
   AsmPara(13) = 0 'reserved
   If CallbackOnEqualSpots Then
      AsmPara(14) = 1 'Flags
   Else
      AsmPara(14) = 0 'Flags
   End If
   

    Static asm(114) As Long    ' c:\piccompare.exe 18.09.2004 07:34:08 (GMT)

    If asm(0) = 0 Then
        asm(0) = &H57EC8B55:  asm(1) = &H6D8B5356:  asm(2) = &HC458B08:   asm(3) = &H3BB
        asm(4) = &H8BE3F700:  asm(5) = &HD82B105D:  asm(6) = &H8B345D89:  asm(7) = &H452B0845
        asm(8) = &H14453B24:  asm(9) = &H458B037C:  asm(10) = &H2C458914: asm(11) = &H2B0C458B
        asm(12) = &H453B2045: asm(13) = &H8B037C14: asm(14) = &H45891445: asm(15) = &H2C75FF28
        asm(16) = &HFF2875FF: asm(17) = &HF9E80075: asm(18) = &H50000000: asm(19) = &HFF2C75FF
        asm(20) = &H75FF2875: asm(21) = &HEAE804:   asm(22) = &H8B5B0000: asm(23) = &HFFE181C8
        asm(24) = &H8B000000: asm(25) = &HFFE281D3: asm(26) = &H2B000000: asm(27) = &HF983CA
        asm(28) = &HD9F7027D: asm(29) = &H77184D3B: asm(30) = &HC1C88B51: asm(31) = &HE18108E9
        asm(32) = &HFF:       asm(33) = &HEAC1D38B: asm(34) = &HFFE28108: asm(35) = &H2B000000
        asm(36) = &HF983CA:   asm(37) = &HD9F7027D: asm(38) = &H77184D3B: asm(39) = &HC1C88B2D
        asm(40) = &HE18110E9: asm(41) = &HFF:       asm(42) = &HEAC1D38B: asm(43) = &HFFE28110
        asm(44) = &H2B000000: asm(45) = &HF983CA:   asm(46) = &HD9F7027D: asm(47) = &H77184D3B
        asm(48) = &H65BA0F09: asm(49) = &HD720038:  asm(50) = &H458329EB: asm(51) = &HBA0F0130
        asm(52) = &H72003865: asm(53) = &H1C7D831E: asm(54) = &H55187400: asm(55) = &HFF2C75FF
        asm(56) = &H458B2875: asm(57) = &H2C452B08: asm(58) = &H5024452B: asm(59) = &HFF2075FF
        asm(60) = &H8B5D1C55: asm(61) = &H45012845: asm(62) = &H3BB6620:  asm(63) = &HE3F76600
        asm(64) = &H1004501:  asm(65) = &H458B0445: asm(66) = &H20453B0C: asm(67) = &HFF1A8F0F
        asm(68) = &H45C7FFFF: asm(69) = &H20:       asm(70) = &H2C458B00: asm(71) = &H83244501
        asm(72) = &H65F701E8: asm(73) = &H34450310: asm(74) = &H1004501:  asm(75) = &H458B0445
        asm(76) = &H24453B08: asm(77) = &HFEE18F0F: asm(78) = &H458BFFFF: asm(79) = &H5F5E5B30
        asm(80) = &H10C25D:   asm(81) = &H8B0CEC83: asm(82) = &HBB142444: asm(83) = &H3
        asm(84) = &H5D8BE3F7: asm(85) = &H33D82B10: asm(86) = &H240489C0: asm(87) = &H4244489
        asm(88) = &H8244489:  asm(89) = &H1024748B: asm(90) = &H1824548B: asm(91) = &H14244C8B
        asm(92) = &H240401AC: asm(93) = &H244401AC: asm(94) = &H4401AC04: asm(95) = &H75490824
        asm(96) = &H4AF303EF: asm(97) = &H448BE675: asm(98) = &H64F71424: asm(99) = &HD88B1824
        asm(100) = &H48BD233: asm(101) = &H89F3F724: asm(102) = &HD2332404: asm(103) = &H424448B
        asm(104) = &H4489F3F7: asm(105) = &HD2330424: asm(106) = &H824448B: asm(107) = &H4489F3F7
        asm(108) = &H448B0824: asm(109) = &HE0C10824: asm(110) = &H24440B08: asm(111) = &H8E0C104
        asm(112) = &H8324040B: asm(113) = &HCC20CC4: asm(114) = &H0
    End If

  
   'call Asm Function
   nResult = CallWindowProc(VarPtr(asm(0)), VarPtr(AsmPara(0)), 0, 0, 0)
   DoASMCompare = (nTotalSpots - nResult) / nTotalSpots * 100
        
   DeleteObject (hDibA)
   DeleteObject (hDibB)
End Function


Private Function GetBitmapData(SomePicture As StdPicture, hDib As Long, _
        BmpInfoStruct As BITMAPINFO, Optional ForceCopy As Boolean = True) As Long
    'Get a Pointer to the 24 Bit RGB Data of a StdPicture
    'If the original Data is available in 24Bpp, and ForceCopy=false,
    'the Pointer to the original Picture Data is returned, otherwise a DIB
    'is created, the Data is copied into the DIB and the Handle is returned in hDip.
    'In that case the caling Function is responsible to delete the DIB Object
   
    'IN: SomePicture
    'IN: ForceCopy
    'OUT: hDib: Handle to a created DIB (if one was created)
    'OUT: BmpInfoStruct of the created DIB
    'RETURNS: Pointer to the 24Bpp RGB Data
    '
    'If ForceCopy=false and the original Data is available in 24Bpp, 0 is returned in hDib
    Dim udtBmpStruct As BITMAP
    Dim lpData As Long
    Dim hDesktopDC As Long
    Dim Result As Long

    'get Infos
    If GetObject(SomePicture, Len(udtBmpStruct), udtBmpStruct) = 0 Then
        Err.Raise 513, , "GetBitmapData: GetObject Kann auf Bilddaten nicht zugreifen !"
        Exit Function 'We could'nt access the Data at all
    ElseIf (udtBmpStruct.bmWidthBytes And 3) <> 0 Then
        'Win2k oddity: PadBytes are calculated wrong !
        udtBmpStruct.bmWidthBytes = udtBmpStruct.bmWidthBytes + 2
    End If
  
    'init BitmapInfoHeader
    With BmpInfoStruct.bmiHeader
        .biSize = Len(BmpInfoStruct.bmiHeader)
        .biWidth = udtBmpStruct.bmWidth
        .biHeight = udtBmpStruct.bmHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = BI_RGB
        .biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
    End With
  
  
    If udtBmpStruct.bmBits = 0 Or udtBmpStruct.bmBitsPixel <> 24 Or ForceCopy = True Then
        'Create DIB:
        hDib = CreateDIBSection(0, BmpInfoStruct, DIB_RGB_COLORS, VarPtr(lpData), 0, 0)
        If hDib = 0 Then
           Err.Raise 513, , "GetBitmapData: Konnte DIB nicht erstellen !"
           Exit Function
        End If
        
        'Is the Format of the Source ok, or do we need some Translation ?
        If udtBmpStruct.bmBits <> 0 And udtBmpStruct.bmBitsPixel = 24 Then
            'We can access the original Data and the Format fits.
            RtlMoveMemory lpData, udtBmpStruct.bmBits, BmpInfoStruct.bmiHeader.biSizeImage
        Else
            'Translation takes a bit longer.
            'from 16 and 32Bpp to 24Bpp works fine, but it seams there is a
            'Problem with 256 Palette Colors. Why ? Don't ask me.
            hDesktopDC = GetDC(0)
            Result = GetDIBits(hDesktopDC, SomePicture.handle, 0, udtBmpStruct.bmHeight, _
                ByVal lpData, BmpInfoStruct, DIB_RGB_COLORS)
            If Result = 0 Then
               Err.Raise 513, , "GetBitmapData: GetDIBits kann auf Bilddaten nicht zugreifen !"
            ElseIf ReleaseDC(0, hDesktopDC) = 0 Then
               Err.Raise 513, , "GetBitmapData: ReleaseDC ist fehlgeschlagen !"
            End If
        End If
        GetBitmapData = lpData
    Else
        GetBitmapData = udtBmpStruct.bmBits
        hDib = 0
    End If
 
End Function

'---- Ende Modul "modPicCompare" alias modPicCompare.bas ----
'----- Anfang Modul "modCallback" alias modCallback.bas -----
Option Explicit

Public Sub CallbackFunc(ByVal X As Long, ByVal Y As Long, _
         ByVal SpotSizeX As Long, ByVal SpotSizeY As Long)
   
    Form1.picB.Line (X, Y)-(X + SpotSizeX - 1, Y + SpotSizeY - 1), RGB(255, 0, 0), BF
End Sub


'------ Ende Modul "modCallback" alias modCallback.bas ------
'-------------- Ende Projektdatei Projekt1.vbp --------------