VB 5/6-Tipp 0800: Pixelgenaue Kollisions-Erkennung transparenter Bitmaps
von Zardoz
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: | 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: |
'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-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | |||||||
VB5 | |||||||
VB6 |
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.