Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0794: pixelgenaue Kollisionserkennung unregelmäßiger Grafiken

VB 5/6-Tipp 0794: pixelgenaue Kollisionserkennung unregelmäßiger Grafiken

 von Lucky Luke

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, GetPixel

Download: Download des Beispielprojektes [5,87 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 Tipp.vbp ---------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP6) (comdlg32.ocx)' wird benötigt.

'-------- Anfang Formular "Form1" alias frmTipp.frm  --------
' Steuerelement: Standarddialog-Steuerelement "Com1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "Text4"
' Steuerelement: Textfeld "Text3"
' Steuerelement: Textfeld "Text2"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Bildfeld-Steuerelement "Anzeige"
' Steuerelement: Beschriftungsfeld "Label5"
' Steuerelement: Beschriftungsfeld "Label4"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"
'Programmiert von Lucas Leichsenring

Option Explicit

Private Declare Function GetPixel Lib "gdi32" ( _
                         ByVal hdc As Long, _
                         ByVal x As Long, _
                         ByVal y As Long) As Long
 'Zum Ermitteln der Farbe eines Pixels
 'Diese API-Funktion ist identisch mit der VB-Funktion
 '"Point", jedoch ist GetPixel um einiges schneller

Private Declare Function BitBlt Lib "gdi32" (ByVal _
        NachHdc As Long, ByVal x As Long, ByVal _
        y As Long, ByVal w As Long, ByVal h As Long, ByVal _
        vonHdc As Long, ByVal vonX As Long, ByVal _
        vonY As Long, ByVal Modus As Long) As Long

Private Const BIT_COPY = &HCC0020
 'benötigt für BitBlt

Private Kol As Boolean
 'True --> Kollision; False --> keine Kollision

Private Sub Command1_Click()
Call Berechnen

If Kol = False Then
 Label5.Caption = "keine Kollision"
Else
  Label5.Caption = "KOLLISION!!!"
  Kol = False
   'Kol muss zurückgesetzt werden, denn wenn beim nächsten Durchlauf
   'keine Kollision gefunden wurde, belibt Kol auf True und so würde
   'fälschlicherweise "Kollision" angezeigt werden.
End If
 'Nach Beendigung der Berechnung Auswertung von Kol
 'und entsprechende Anzeige
End Sub

Private Sub Form_Load()

 With Com1
Again1:
  .DialogTitle = "BMP-Datei auswählen!"
  .Filter = "Windows-Bitmaps (*.bmp) | *.bmp"
  .ShowOpen
  If .FileName = "" Then Goto Again1
  Picture1.Picture = LoadPicture(.FileName)
Again2:
  .ShowOpen
  If .FileName = "" Then Goto Again2
   'Es muss ein Bild ausgewählt werden
  Picture2.Picture = LoadPicture(.FileName)
 End With
  'Die 2 Bilder vom Benutzer auswählen lassen & laden
  
End Sub


Private Sub Berechnen()
Dim a As Integer, b As Integer
Dim DisX As Integer, DisY As Integer
Dim x1 As Integer, y1 As Integer 'Position der einen Grafik
Dim x2 As Integer, y2 As Integer 'Position der anderen Grafik

x1 = Val(Text1.Text): y1 = Val(Text2.Text)
x2 = Val(Text3.Text): y2 = Val(Text4.Text)
 'Zuweisung der Werte aus den Textboxen
 
DisX = x1 - x2
DisY = y1 - y2
 'Die Distanz zwischen den Bildern
 
Anzeige.Cls
Call BitBlt(Anzeige.hdc, x1, y1, Picture1.ScaleWidth, Picture1.ScaleHeight, _
 Picture1.hdc, 0, 0, BIT_COPY)
Call BitBlt(Anzeige.hdc, x2, y2, Picture2.ScaleWidth, Picture2.ScaleHeight, _
 Picture2.hdc, 0, 0, BIT_COPY)
 'Grafiken auf Picturebox kopieren, nur um die Situation zu veranschaulichen
 
For a = 0 To Picture1.ScaleWidth
 For b = 0 To Picture1.ScaleHeight
  If GetPixel(Picture1.hdc, a, b) <> vbWhite Then 'Wenn das Pixel von Picture1
   'mit den Koordinaten a/b nicht weiß ist, fortfahren
   If GetPixel(Picture2.hdc, a + (DisX), b + (DisY)) <> vbWhite Then
    'Das eben geprüfte Pixel von Picture2 liegt auf der selben Stelle wie
    'das Pixel zuvor von Picture1, weil die Distanz wieder aufaddiert wird.
    'Nur fortfahren, wenn es nicht weiß ist
    If GetPixel(Picture2.hdc, a + (DisX), b + (DisY)) <> -1 Then
     'GetPixel liefert -1, wenn es einen Fehler gab. Das passiert in dem Fall,
     'wenn das zu prüfenden Pixel außerhalb von Picture2 liegt
     'Wenn DisX oder DisY negativ sind, liegt es außerhalb
     'Nur fortfahren, wenn es auf einem Pixel von Picture1 liegt
     Kol = True
     Exit Sub
      'Kollision --> Ja, da:
      ' - Pixel von Picture1 nicht weiß ist
      ' - darüber liegendes Pixel von Picture2 nicht weiß ist
      ' - kein fehler aufgetreten ist
      'Prozedur beenden, da Kollison entdeckt, somit keine weitere Überprüfung notwendig
    End If
   End If
  End If
 Next b
Next a
 'Die Schleife von a geht die X-Koordinaten von Picture1 durch und
 'die andere Schleife die Y-Koordinaten.
End Sub





'--------- Ende Formular "Form1" alias frmTipp.frm  ---------
'---------------- Ende Projektdatei Tipp.vbp ----------------