home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Spacefight619883142002.psc / ModCollision.bas < prev    next >
Encoding:
BASIC Source File  |  2001-11-14  |  4.7 KB  |  116 lines
  1. Attribute VB_Name = "ModCollision"
  2. Option Explicit
  3. Type RECT
  4.     Left As Long
  5.     Top As Long
  6.     Right As Long
  7.     Bottom As Long
  8.     End Type
  9. Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  10. Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  11. Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  12. Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
  13. 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
  14. Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  15. Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  16. Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
  17.     ' Collision Detection (Sprites)
  18.     ' - Acknowledgement here goes to Richard
  19.     '     Lowe (riklowe@hotmail.com) for his colli
  20.     '     sion detection
  21.     ' algorithm which I have used as the bas
  22.     '     is of my collision detection algorithm.
  23.     '     Most of the logic in
  24.     ' here is radically different though, an
  25.     '     d his algorithm originally didn't deallo
  26.     '     cate memory properly ;-)
  27.     ' - All X/Y/Width/Height values MUST be
  28.     '     measured in pixels (ScaleMode = 3).
  29.     ' - Compares bounding rectangles, and if
  30.     '     they overlap, it goes to a pixel-by-pixe
  31.     '     l comparison.
  32.     'This therefore has detection down to th
  33.     '     e pixel level.
  34.     ' Function assumes you are using Masking
  35.     '     sprites (not an unreasonable assumption,
  36.     '     I'm sure you'll agree).
  37.     ' - e.g. To test if collision has occurr
  38.     '     ed between two sprites, one called "Ball
  39.     '     ", the other "Bat":
  40. Public Function CollisionDetect(ByVal x1 As Long, ByVal y1 As Long, ByVal X1Width As Long, ByVal Y1Height As Long, _
  41.     ByVal Mask1LocX As Long, ByVal Mask1LocY As Long, ByVal Mask1Hdc As Long, ByVal x2 As Long, ByVal y2 As Long, _
  42.     ByVal X2Width As Long, ByVal Y2Height As Long, ByVal Mask2LocX As Long, ByVal Mask2LocY As Long, _
  43.     ByVal Mask2Hdc As Long) As Boolean
  44.     Dim MaskRect1 As RECT
  45.     Dim MaskRect2 As RECT
  46.     Dim DestRect As RECT
  47.     Dim i As Long
  48.     Dim j As Long
  49.     Dim Collision As Boolean
  50.     Dim MR1SrcX As Long
  51.     Dim MR1SrcY As Long
  52.     Dim MR2SrcX As Long
  53.     Dim MR2SrcY As Long
  54.     Dim hNewBMP As Long
  55.     Dim hPrevBMP As Long
  56.     Dim tmpObj As Long
  57.     Dim hMemDC As Long
  58.     MaskRect1.Left = x1
  59.     MaskRect1.Top = y1
  60.     MaskRect1.Right = x1 + X1Width
  61.     MaskRect1.Bottom = y1 + Y1Height
  62.     MaskRect2.Left = x2
  63.     MaskRect2.Top = y2
  64.     MaskRect2.Right = x2 + X2Width
  65.     MaskRect2.Bottom = y2 + Y2Height
  66.     i = IntersectRect(DestRect, MaskRect1, MaskRect2)
  67.     If i = 0 Then
  68.         CollisionDetect = False
  69.     Else
  70.         If x1 > x2 Then
  71.             MR1SrcX = 0
  72.             MR2SrcX = x1 - x2
  73.         Else
  74.             MR2SrcX = 0
  75.             MR1SrcX = x2 - x1
  76.         End If
  77.         If y1 > y2 Then
  78.             MR2SrcY = y1 - y2
  79.             MR1SrcY = 0
  80.         Else
  81.             MR2SrcY = 0 ' here
  82.             MR1SrcY = y2 - y1 - 1
  83.         End If
  84.         hMemDC = CreateCompatibleDC(Screen.ActiveForm.hdc)
  85.         hNewBMP = CreateCompatibleBitmap(Screen.ActiveForm.hdc, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top)
  86.         hPrevBMP = SelectObject(hMemDC, hNewBMP)
  87.         ' Blit the first sprite into it
  88.         i = BitBlt(hMemDC, 0, 0, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, _
  89.         Mask1Hdc, MR1SrcX + Mask1LocX, MR1SrcY + Mask1LocY, vbSrcCopy)
  90.         ' Logical OR the second sprite with the
  91.         '     first sprite
  92.         i = BitBlt(hMemDC, 0, 0, DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top, _
  93.         Mask2Hdc, MR2SrcX + Mask2LocX, MR2SrcY + Mask2LocY, vbSrcPaint)
  94.         Collision = False
  95.         For i = 0 To DestRect.Bottom - DestRect.Top - 1
  96.             For j = 0 To DestRect.Right - DestRect.Left - 1
  97.                 If GetPixel(hMemDC, j, i) = 0 Then ' If there are any black pixels
  98.                     Collision = True
  99.                     Exit For
  100.                 End If
  101.             Next
  102.             If Collision = True Then
  103.                 Exit For
  104.             End If
  105.         Next
  106.         CollisionDetect = Collision
  107.         ' Destroy any allocated objects and DC's
  108.         tmpObj = SelectObject(hMemDC, hPrevBMP)
  109.         tmpObj = DeleteObject(tmpObj)
  110.         tmpObj = DeleteDC(hMemDC)
  111.     End If
  112. End Function
  113.  
  114.  
  115.  
  116.