Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0800: Pixelgenaue Kollisions-Erkennung transparenter Bitmaps

 von 

Beschreibung 

Der Code demonstriert die Anwendung des Tipps Tipp 669 auf transparente Grafiken. Der Kollisions-Erkennung mit Regionen, wurde eine zweite, grobe Kollisions-Erkennung mit Rechtecken vorgeschaltet, was die Performance verbessert. Ein Problem, bei diesem Verfahren, war das relativ zeitaufwändige Erstellen der Regionen aus einer Grafik. Die Function CreateRegionFromPicture in Modul 2 stellt hierfür eine schnelle Lösung bereit. Selbst grössere Bitmaps werden, je nach Hardware, im niedrigen Zehntelsekunden-Bereich in eine Region umgerechnet.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

BitBlt, CombineRgn, CreateCompatibleDC, CreateRectRgn, DeleteDC, DeleteObject, ExtCreateRegion, GetDIBits, GetObjectA (GetObjectAPI), GetPixel, GetWindowRect, IntersectRect, OffsetRgn, PaintRgn, SelectObject, SetCursorPos, SetRect, SetStretchBltMode, ShowCursor, StretchBlt, TextOutA (TextOut), TransparentBlt

Download:

Download des Beispielprojektes [56,16 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: Bildfeld-Steuerelement "Picture4"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Bildfeld-Steuerelement "Picture3"
' Steuerelement: Bildfeld-Steuerelement "Picture2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Anzeige-Steuerelement "Image1"
' Steuerelement: Beschriftungsfeld "Label1"
' Pixelgenaue Kollisions-Erkennung transparenter Bitmaps
' Copyright © 2012 by Zardoz

Option Explicit

Private Mask1 As Long, Mask2 As Long
Private SW1 As Long, SH1 As Long
Private SW2 As Long, SH2 As Long
Private SW3 As Long, SH3 As Long
Private XGhost As Single, YGhost As Single
Private LastX1 As Long, LastY1 As Long
Private LastX2 As Long, LastY2 As Long
Private Rgn1 As Long, Rgn2 As Long, Rgn3 As Long
Private flg1 As Boolean, flgMove As Boolean
Private Pi As Single, flgMouse As Boolean

Private Sub Form_Load()
  ' Einstellungen Form
  
  With Me
    .MousePointer = vbHourglass
    .ScaleMode = vbPixels
    .BackColor = RGB(96, 96, 96)
    .Caption = "Pixelgenaue Kollisions-Erkennung " & _
      "transparenter Bitmaps" & IIf(App.LogMode = 0, _
      Space$(20) & "Compile me.", "")
    .WindowState = vbMaximized
    .KeyPreview = True
  End With
  flg1 = False
  
End Sub

Private Sub Form_Activate()
  
  If flg1 = True Then Exit Sub
  flg1 = True
  DoEvents
  Call Calculate
  Me.MousePointer = vbDefault

End Sub

Private Sub Calculate()
  ' Einstellungen
  
  Dim Out As String, RetVal As Long
  Dim Dat1 As String, R1 As RECT
  
  SW3 = Me.ScaleWidth * 0.75
  SH3 = Me.ScaleHeight * 0.8
  Pi = 4 * Atn(1)
  flgMove = True
  
  Dat1 = App.Path & "\Ghost.bmp"
  RetVal = FileToPicture(Dat1, Picture1, SW1, SH1, Mask1, Rgn1)
  If RetVal = 0 Then Unload Me
  
  Dat1 = App.Path & "\Witch.bmp"
  RetVal = FileToPicture(Dat1, Picture2, SW2, SH2, Mask2, Rgn2)
  If RetVal = 0 Then Unload Me
  
  ' Leere Region für Kollisionserkennung erstellen
  Rgn3 = CreateRectRgn(0, 0, 0, 0)
  
  ' Regionen zur Kontrolle zeichnen
  With Picture3
    .BorderStyle = vbBSNone
    .ScaleMode = vbPixels
    .BackColor = vbMagenta
    .Move 0, 0, IIf(SW1 > SW2, SW1, SW2), SH1 + SH2
    .AutoRedraw = True
    .FillStyle = vbFSSolid
    .FillColor = vbBlue
    Call PaintRgn(.hdc, Rgn1)
    Call OffsetRgn(Rgn2, 0, SH1)
    Call PaintRgn(.hdc, Rgn2)
    Call OffsetRgn(Rgn2, 0, -SH1)
    .FontSize = 14
    .FontBold = True
    .ForeColor = vbWhite
    Out = "Region " & Chr$(34) & "Geist" & Chr$(34)
    Call TextOut(.hdc, 4, 4, Out, Len(Out))
    Out = "Region " & Chr$(34) & "Hexe" & Chr$(34)
    Call TextOut(.hdc, 4, SH1 + 4, Out, Len(Out))
    .FillStyle = vbFSTransparent
    .FontSize = Me.FontSize
    .FontBold = False
    Set Image1.Picture = .Image
    .Cls
    .Move 8, 8, SW3, SH3
    Call GetWindowRect(.hwnd, R1)
  End With
  
  Call DrawGround
  LastX1 = 0
  LastY1 = 0
  LastX2 = 0
  LastY2 = 0
  flgMouse = True
  Label1.Move 8 + (SW3 - 180) \ 2, SH3 + 8, 180
  Label1.BackColor = vbYellow
  Image1.Move 16 + SW3, 8
  Image1.Enabled = False
  Image1.Visible = True

  Call SetCursorPos((R1.Left + R1.Right) \ 2, _
    (R1.Top + R1.Bottom) \ 2)
  
  Call Timer1_Timer
  Timer1.Interval = 12
  Timer1.Enabled = True
  Picture3.Visible = True

End Sub

Private Function FileToPicture(Dat1 As String, Dest As PictureBox, _
  SW As Long, SH As Long, Mask As Long, Region As Long) As Long
  ' Grafik laden, in Picturebox zeichnen + Region erstellen

  Dim P1hdc As Long, P1OldHandle As Long
  Dim TmpPic As StdPicture
  
  If Dir$(Dat1) = "" Then
    MsgBox "Datei nicht gefunden:" & vbCr & Dat1, _
      vbExclamation + vbOKOnly, Me.Caption
    FileToPicture = 0
    Exit Function
  End If
  ' Bild laden
  Set TmpPic = LoadPicture(Dat1)
  ' Region erstellen
  Region = CreateRegionFromPicture(TmpPic.Handle)
  ' Breite + Höhe holen
  Call GetMapMetrics(TmpPic.Handle, SW, SH)

  P1hdc = CreateCompatibleDC(0)
  P1OldHandle = SelectObject(P1hdc, TmpPic.Handle)
  With Dest
    .Visible = False
    .BorderStyle = vbBSNone
    .ScaleMode = vbPixels
    .Move 0, 0, SW, SH
    .AutoRedraw = True
    ' Bild zeichnen
    Call BitBlt(.hdc, 0, 0, SW, SH, _
      P1hdc, 0, 0, vbSrcCopy)
    ' Maskenfarbe auslesen
    Mask = GetPixel(.hdc, 0, 0)
  End With
  Call SelectObject(P1hdc, P1OldHandle)
  Call DeleteDC(P1hdc)
  Set TmpPic = LoadPicture()
  FileToPicture = 1

End Function

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' Maus ein
  
  If flgMouse = False Then Call Mouse_On

End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' Maus ein
  
  If flgMouse = False Then Call Mouse_On

End Sub

Private Sub Picture3_Click()
  ' "Hexe" bewegen Start / Stop
  
  flgMove = Not flgMove

End Sub

Private Sub Picture3_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  ' "Geist" mit der Maus bewegen
  
  XGhost = x - SW1 / 2
  YGhost = y - SH1 / 2
  If flgMouse = True Then Call Mouse_Off
  
End Sub

Private Sub Timer1_Timer()
  ' Grafikausgabe + Kollisionsabfrage
  
  Static Pos1 As Long
  Dim Wnk As Single, N As Long, XWitch As Single, YWitch As Single
  Dim RgnFlg As Long, R1 As RECT, R2 As RECT
  Dim flgKollision As Boolean, Txt As String
  
  ' Fenster minimiert. Da machen wir nix.
  If Me.WindowState = vbMinimized Then Exit Sub
  ' Hintergrund holen
  Call BitBlt(Picture3.hdc, 0, 0, SW3, SH3, _
    Picture4.hdc, 0, 0, vbSrcCopy)
  ' Position "Hexe" berechnen
  N = 600 ' Positionen für eine "Runde"
  If flgMove = True Then Pos1 = (Pos1 + 1) Mod N
  Wnk = 2 * Pi / N * Pos1
  XWitch = (SW3 - SW2) / 2 * (1 + Cos(Wnk))
  YWitch = (SH3 - SH2) / 2 * (1 - Sin(2 * Wnk))
  
  ' "Hexe" zeichnen
  Call TransparentBlt(Picture3.hdc, XWitch, YWitch, SW2, SH2, _
    Picture2.hdc, 0, 0, SW2, SH2, Mask2)
  ' "Geist" zeichnen
  Call TransparentBlt(Picture3.hdc, XGhost, YGhost, SW1, SH1, _
    Picture1.hdc, 0, 0, SW1, SH1, Mask1)

  ' Grobe Kollisionsabfrage. Überlagern sich die Rechtecke?
  flgKollision = False
  Call SetRect(R1, XGhost, YGhost, XGhost + SW1, YGhost + SH1)
  Call SetRect(R2, XWitch, YWitch, XWitch + SW2, YWitch + SH2)
  If IntersectRect(R1, R1, R2) <> 0 Then
    ' Feine Kollisionsabfrage. Pixelgenau
    ' Region "Geist" an aktuelle Position verschieben
    Call OffsetRgn(Rgn1, XGhost - LastX1, YGhost - LastY1)
    ' Region "Hexe" an aktuelle Position verschieben
    Call OffsetRgn(Rgn2, XWitch - LastX2, YWitch - LastY2)
    ' And-Verknüpfung der Regionen
    RgnFlg = CombineRgn(Rgn3, Rgn1, Rgn2, RGN_AND)
    ' Kollision?
    If RgnFlg <> NULLREGION Then flgKollision = True
    ' Positionen merken
    LastX1 = XGhost
    LastY1 = YGhost
    LastX2 = XWitch
    LastY2 = YWitch
  End If
  
  ' Textausgabe
  If flgKollision = True Then
    Txt = "Kollision !!!"
  Else
    Txt = "Keine Kollision"
  End If
  If Label1.Caption <> Txt Then Label1.Caption = Txt
  Picture3.Refresh ' Auffrischen erzwingen
  
End Sub

Private Sub Mouse_Off()
  ' Mauszeiger aus
  
  Do: Loop Until ShowCursor(0) < 0
  flgMouse = False

End Sub

Private Sub Mouse_On()
  ' Mauszeiger an
  
  Do: Loop Until ShowCursor(1) >= 0
  flgMouse = True

End Sub

Private Sub DrawGround()
  ' Hintergrund zeichnen
  
  Dim i As Long, j As Long, k As Long, Out$, N As Long
  Dim Rad As Single, Wnk As Single, E As String, P4hdc As Long
  Dim XPos As Single, YPos As Single, OldMode As Long
  
  k = 0
  N = 15
  Rad = 8
  Out = UCase$("Graffiti")
  With Picture4
    .Visible = False
    .BorderStyle = vbBSNone
    .ScaleMode = vbPixels
    .BackColor = RGB(160, 0, 0)
    .Move 0, 0, SW3, SH3
    .AutoRedraw = True
    .ForeColor = RGB(160, 160, 160)
    .DrawWidth = 3
    ' Mauer zeichnen
    For j = SH3 - 1 To 0 Step -40
      Picture4.Line (0, j)-(SW3 - 1, j)
      For i = k * 40 To SW3 - 1 Step 80
        Picture4.Line (i, j)-Step(0, -40)
      Next i
      k = 1 - k
    Next j
    .DrawWidth = 1
    ' Text zeichnen
    .FontSize = 48
    .FontItalic = True
    On Error Resume Next
    .FontName = "Arial Black"
    Err.Clear
    On Error Goto 0
    P4hdc = .hdc
    For i = 0 To Len(Out) - 1
      E = Mid$(Out, i + 1, 1)
      XPos = 50 + i * 60
      YPos = 350 - i * 30
      .ForeColor = vbRed
      For j = 0 To N - 1
        Wnk = 2 * Pi / N * j
        Call TextOut(P4hdc, XPos + Rad * Cos(Wnk), _
          YPos - Rad * Sin(Wnk), E, 1)
      Next j
      .ForeColor = RGB(0, 128, 255)
      Call TextOut(P4hdc, XPos, YPos, E, 1)
    Next i
    .FontName = Me.FontName
    .FontSize = Me.FontSize
    .FontItalic = False
  End With
  ' Text spiegeln
  OldMode = SetStretchBltMode(P4hdc, COLORONCOLOR)
  Call StretchBlt(P4hdc, SW3 - 1, 0, -SW3, SH3, _
    P4hdc, 0, 0, SW3, SH3, vbSrcCopy)
  Call SetStretchBltMode(P4hdc, OldMode)
  
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  ' Beenden mit Esc
  
  If KeyCode = vbKeyEscape Then Unload Me

End Sub

Private Sub Form_Unload(Cancel As Integer)
  ' Beim Beenden Speicher aufräumen
  
  Timer1.Enabled = False
  Call Mouse_On
  If Rgn1 <> 0 Then Call DeleteObject(Rgn1)
  If Rgn2 <> 0 Then Call DeleteObject(Rgn2)
  If Rgn3 <> 0 Then Call DeleteObject(Rgn3)

End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------
' Api
Option Explicit

' Typen
Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

' Deklarationen

' gdi32
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Public 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
Public Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long

' user32
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

' msimg32
Public Declare Function TransparentBlt Lib "msimg32" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hDCSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long

' Konstanten
' StretchBlt() Modes
Public Const COLORONCOLOR As Long = 3

' CombineRgn() Styles
Public Const RGN_AND As Long = 1

' Region Flags
Public Const NULLREGION As Long = 1
'---------- Ende Modul "Module1" alias Module1.bas ----------
'--------- Anfang Modul "Module2" alias Module2.bas ---------
' Region aus Grafik erstellen
' Copyright © 2012 by Zardoz

Option Explicit

' Typen
' Bitmap Header Definition
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

' structures for defining DIBs
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

' Deklarationen
' gdi32
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function ExtCreateRegion Lib "gdi32" (lpXform As Any, ByVal nCount As Long, lpRgnData As Any) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

' Konstanten
' DIB color table identifiers
Private Const DIB_RGB_COLORS As Long = 0 ' color table in RGBs

' constants for the biCompression field
Private Const BI_RGB As Long = 0

' Region-Type
Private Const RDH_RECTANGLES As Long = 1
'

Public Function CreateRegionFromPicture(PicHandle As Long, _
  Optional Mask As Long = -1) As Long
  ' Region aus Bitmap generieren
  
  Dim SW As Long, SH As Long, x1 As Long, y1 As Long
  Dim Z1 As Long, P1hdc As Long, P1OldHandle As Long
  Dim MapData() As Long, Buffer() As Long
  Dim MapInfo As BITMAPINFO
  
  If PicHandle = 0 Then
    MsgBox "Error:" & vbCr & "Handle = 0", vbExclamation + vbOKOnly
    CreateRegionFromPicture = 0
    Exit Function
  End If
  
  Call GetMapMetrics(PicHandle, SW, SH)
  ReDim MapData(SW - 1, SH - 1), Buffer(8 + 4& * SW * SH - 1)
  
  With MapInfo.bmiHeader
    .biSize = Len(MapInfo.bmiHeader)
    .biWidth = SW
    .biHeight = -SH
    .biPlanes = 1
    .biBitCount = 32
    .biCompression = BI_RGB
    .biSizeImage = 0
    .biXPelsPerMeter = 0
    .biYPelsPerMeter = 0
    .biClrUsed = 0
    .biClrImportant = 0
  End With
  
  With MapInfo.bmiColors
    .rgbBlue = 0
    .rgbGreen = 0
    .rgbRed = 0
    .rgbReserved = 0
  End With

  ' Bilddaten in Array einlesen
  P1hdc = CreateCompatibleDC(0)
  P1OldHandle = SelectObject(P1hdc, PicHandle)
  Call GetDIBits(P1hdc, PicHandle, 0, SH, _
    MapData(0, 0), MapInfo, DIB_RGB_COLORS)
  Call SelectObject(P1hdc, P1OldHandle)
  Call DeleteDC(P1hdc)
  
  If Mask = -1 Then
    ' Maskenfarbe holen. Bytes sind bereits getauscht
    Mask = MapData(0, 0)
  Else
    ' Bytes Maskenfarbe tauschen
    Mask = (Mask And vbRed) * &H10000 + (Mask And vbGreen) + _
      (Mask And vbBlue) \ &H10000
  End If
  
  Z1 = 8
  For y1 = 0 To SH - 1
    For x1 = 0 To SW - 1
      If MapData(x1, y1) <> Mask Then
        Buffer(Z1) = x1
        Buffer(Z1 + 1) = y1
        Buffer(Z1 + 2) = x1 + 1
        Buffer(Z1 + 3) = y1 + 1
        Z1 = Z1 + 4
      End If
    Next x1
  Next y1
  Buffer(0) = 32 ' Headerlänge
  Buffer(1) = RDH_RECTANGLES ' Regiontyp
  Buffer(2) = Z1 / 4 - 2 ' Anzahl Rechtecke
  
  ' Region erzeugen
  CreateRegionFromPicture = _
    ExtCreateRegion(ByVal 0&, 4& * Z1, Buffer(0))
  
  ' Speicher freigeben
  Erase MapData, Buffer

End Function

Public Sub GetMapMetrics(PicHandle As Long, _
  SW As Long, SH As Long)
  ' Breite und Höhe einer Bitmap
  
  Dim Bmp As BITMAP
  
  Call GetObjectAPI(PicHandle, Len(Bmp), Bmp)
  SW = Bmp.bmWidth
  SH = Bmp.bmHeight

End Sub
'---------- Ende Modul "Module2" alias Module2.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.