|
|
Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Dim DX7 As New DirectX7 'The main object
Dim DD7 As DirectDraw7 'DirectDraw7 Object
Dim Primary As DirectDrawSurface7 'This is the main screen
Dim BackBuffer As DirectDrawSurface7 'Backbuffer
Dim MovingObj As DirectDrawSurface7 'The moving object
Dim CenterObj As DirectDrawSurface7 'The Center object
Dim DDSDPrim As DDSURFACEDESC2 'Descibes the Screen
Dim DDSDBack As DDSURFACEDESC2 'Describes the backbuffer
Dim DDSDObj As DDSURFACEDESC2 'Describes both objects
Dim DDBLTCOLORKEY As DDCOLORKEY 'Color Key for transparency
'RECTANGLES
Dim RECTScreen As RECT 'Screen Size
Dim RECTObj As RECT 'TRectangle the size of the moving object
Dim RECTCenter As RECT 'So we can blt the Center image in the center
Dim RECTMoving As RECT 'So we can blt the moving object
Dim RECTBLANK As RECT 'A blank rect
'CONSTANTS
Const MOVESPEED = 1
Const PICWIDTH = 150
Const BLTCOLORKEY = 0
Const SCREENWIDTH = 640
Const SCREENHEIGHT = 480
'Moving object's coords
Dim MovingX As Integer 'X
Dim MovingY As Integer 'Y
'Keyboard Flags
Dim UpKeyPress As Boolean 'Is the Up Key pressed?
Dim DownKeyPress As Boolean 'Is the Down Key pressed?
Dim LeftKeyPress As Boolean 'Is the Left Key pressed?
Dim RightKeyPress As Boolean 'Is the Right Key pressed?
'Program Variables
Dim ProgRunning As Boolean 'Is the program running?
Dim RunMainLoop As Boolean 'Says whether to run the Main Loop or not
Dim ProgInit As Boolean 'Whether the program was initialised or not
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'Check for keypresses
If KeyCode = vbKeyLeft Then LeftKeyPress = True
If KeyCode = vbKeyRight Then RightKeyPress = True
If KeyCode = vbKeyDown Then DownKeyPress = True
If KeyCode = vbKeyUp Then UpKeyPress = True
'Exit the program when the user presses Escape
If KeyCode = vbKeyEscape Then Terminate 'Goto the Terminate sub
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
'Check for keypresses
If KeyCode = vbKeyLeft Then LeftKeyPress = False
If KeyCode = vbKeyRight Then RightKeyPress = False
If KeyCode = vbKeyDown Then DownKeyPress = False
If KeyCode = vbKeyUp Then UpKeyPress = False
End Sub
Private Sub Form_Load()
Me.Show 'Make sure the form is show
Set DD7 = DX7.DirectDrawCreate("") 'Create DirectDraw7 ;("") For default driver
Call DD7.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE) 'Fullscreen for fullscreen mode
'Exclusive mode gives our program more time/attention and no other program can use DDraw while this program is running
Call DD7.SetDisplayMode(SCREENWIDTH, SCREENHEIGHT, 8, 0, DDSDM_DEFAULT) 'Set the display mode to 640x480, 8 bits
'Get the screen surface
DDSDPrim.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
DDSDPrim.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
DDSDPrim.lBackBufferCount = 1
Set Primary = DD7.CreateSurface(DDSDPrim) 'Create the primary surface
'Get Backbuffer
Dim Caps As DDSCAPS2
Caps.lCaps = DDSCAPS_BACKBUFFER
Set BackBuffer = Primary.GetAttachedSurface(Caps)
BackBuffer.GetSurfaceDesc DDSDBack
'Set text color for backbuffer
BackBuffer.SetForeColor vbBlue 'Make the text color blue
BackBuffer.SetFontTransparency True 'Make the area around the font transparent
InitSurfaces 'Init Surfaces
ProgInit = True 'Program has successfully initialised
MainLoop 'Run the main loop
End Sub
Public Sub InitSurfaces()
'Init Objects (In System Memory)
DDSDObj.lFlags = DDSD_WIDTH Or DDSD_HEIGHT Or DDSD_CAPS
DDSDObj.ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY Or DDSCAPS_OFFSCREENPLAIN 'OFFSCREENPLAIN means the user doesn't actually get to see the surface (for now!) -- it is just in memory
DDSDObj.lWidth = PICWIDTH 'Change this to whatever your image's width is
DDSDObj.lHeight = PICWIDTH 'Change this to whatever your image's height is
Set MovingObj = DD7.CreateSurfaceFromFile(App.Path & "\Moving.bmp", DDSDObj) 'Create the surface now that we have the information
Set CenterObj = DD7.CreateSurfaceFromFile(App.Path & "\Center.bmp", DDSDObj) 'Create the surface now that we have the information
DDBLTCOLORKEY.high = BLTCOLORKEY ' -
DDBLTCOLORKEY.low = BLTCOLORKEY ' -Setting Low and High to 0 makes black transparent
MovingObj.SetColorKey DDCKEY_SRCBLT, DDBLTCOLORKEY 'Make sure the surface's color key is (black = transparent)
CenterObj.SetColorKey DDCKEY_SRCBLT, DDBLTCOLORKEY 'Make sure the surface's color key is (black = transparent)
'Make RECTObj the size of our object
RECTObj.Bottom = PICWIDTH 'Height is PICWIDTH
RECTObj.Right = PICWIDTH 'Width is PICWIDTH
'Make RECTScreen the size of the screen
RECTScreen.Right = SCREENWIDTH 'Width is 640
RECTScreen.Bottom = SCREENHEIGHT 'Height is 480
End Sub
Public Sub MainLoop()
On Error GoTo ErrHandle
If ProgInit = False Then Exit Sub
ProgRunning = True
Do While ProgRunning = True 'Main Loop starts here
BackBuffer.BltColorFill RECTScreen, RGB(255, 255, 255) 'Fill the backbuffer with white
With RECTCenter
.Left = (SCREENWIDTH / 2) - (PICWIDTH / 2) 'Center the Width...Still need the hight to make it center
.Right = .Left + PICWIDTH 'Now we have the right
.Top = (SCREENHEIGHT / 2) - (PICWIDTH / 2) 'Center the height, the box is centered! Now we need the fourth piece
.Bottom = .Top + PICWIDTH
BackBuffer.BltFast .Left, .Top, CenterObj, RECTObj, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT 'Blit the center object
End With
MoveObject 'Move the Object
'Blit the moving object
With RECTMoving
.Left = MovingX 'Set the left side to MovingX
.Right = MovingX + PICWIDTH 'Set the right side to MovingX + PICWIDTH (image width)
.Top = MovingY 'Set the top side to MovingY
.Bottom = MovingY + PICWIDTH 'Set the bottom side to MovingY + PICWIDTH (image height)
BackBuffer.BltFast .Left, .Top, MovingObj, RECTObj, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
End With
If CheckForPPCollision(MovingObj, CenterObj, RECTMoving, RECTCenter, 0) = True Then
'Execute any thing you want to happen when PixelPerfect Collision Detecion occurs
BackBuffer.DrawText 0, 50, " ixel Perfect Collision!", False 'Draw Text
End If
Call BackBuffer.DrawText(0, 0, "Pixel Perfect Collision Detection Example by Jason Foral", False) 'Draw Text
Call BackBuffer.DrawText(0, 15, "Press Escape To Cancel", False) 'Draw text
'Call BackBuffer.DrawText(0, 30, "MovingX = " & MovingX & ", MovingY = " & MovingY, False) This was just for debugging...
Primary.Flip Nothing, DDFLIP_WAIT 'Flip so we can see all that we blitted
DoEvents 'Let computer do other things
Loop
ErrHandle:
If Err.Number = -2147467259 Then 'Make sure the two Surfaces aren't the same! (Don't have the same name)
Terminate
End If
End Sub
Public Sub MoveObject()
If UpKeyPress Then MovingY = MovingY - MOVESPEED 'Move object up
If RightKeyPress Then MovingX = MovingX + MOVESPEED 'Move object right
If LeftKeyPress Then MovingX = MovingX - MOVESPEED 'Move object left
If DownKeyPress Then MovingY = MovingY + MOVESPEED 'Move object down
If MovingY < 0 Then MovingY = 0
If MovingX < 0 Then MovingX = 0
If MovingX > (SCREENWIDTH - PICWIDTH) Then MovingX = (SCREENWIDTH - PICWIDTH)
If MovingY > (SCREENHEIGHT - PICWIDTH) Then MovingY = (SCREENHEIGHT - PICWIDTH)
End Sub
Public Function CheckForPPCollision(DDSurf1 As DirectDrawSurface7, DDSurf2 As DirectDrawSurface7, RECT1 As RECT, RECT2 As RECT, BlitCOLORKEY As Integer) As Boolean
Dim RECTOverlap As RECT 'Used to record the overlap from RECT1 and RECT2
Dim RECT1Overlap As RECT 'Overlaped portions of RECT1
Dim RECT2Overlap As RECT 'Overlaped portions of RECT2
Dim OverlapWidth As Integer 'Determine the width of the overlap
Dim OverlapHeight As Integer 'Determine the height of the overlap
Dim ByteObj1() As Byte 'Used to analyse a pixel
Dim ByteObj2() As Byte 'Used to analyse a pixel
Dim DDSDBlank As DDSURFACEDESC2 'For use in (DDSurf1.Lock) (DDSurf2.Lock)
Dim i As Integer, j As Integer 'Just for use in loops
Dim PPCollision As Boolean 'States whether we have PixelPerfect collision
'Check for rectangular collisions
If IntersectRect(RECTOverlap, RECT1, RECT2) Then
'RECTANGULAR COLLISION
'Get the RECT structures for the overlapped portions of both surfaces
With RECT1Overlap 'Find the overlap difference in the first RECT
.Top = RECTOverlap.Top - RECT1.Top
.Bottom = RECTOverlap.Bottom - RECT1.Top
.Right = RECTOverlap.Right - RECT1.Left
.Left = RECTOverlap.Left - RECT1.Left
End With
With RECT2Overlap 'Find the overlap difference in the second RECT
.Top = RECTOverlap.Top - RECT2.Top
.Bottom = RECTOverlap.Bottom - RECT2.Top
.Right = RECTOverlap.Right - RECT2.Left
.Left = RECTOverlap.Left - RECT2.Left
End With
'Determine the width and height of the ovrelas (we will use this information for the loop)
OverlapWidth = RECTOverlap.Right - RECTOverlap.Left - 1
OverlapHeight = RECTOverlap.Bottom - RECTOverlap.Top - 1
'Use Lock and GetLockedArray on each surface
DDSurf1.Lock RECT1Overlap, DDSDBlank, DDLOCK_READONLY Or DDLOCK_WAIT, 0
DDSurf1.GetLockedArray ByteObj1
DDSurf2.Lock RECT2Overlap, DDSDBlank, DDLOCK_READONLY Or DDLOCK_WAIT, 0
DDSurf2.GetLockedArray ByteObj2
'Compare the surface data from the overlapping portions of the rectangles
For i = 0 To OverlapWidth
For j = 0 To OverlapHeight
'If BOTH surfaces are non-tranparent at this pixel...
If (ByteObj1(i + RECT1Overlap.Left, j + RECT1Overlap.Top) <> BlitCOLORKEY) And (ByteObj2(i + RECT2Overlap.Left, j + RECT2Overlap.Top) <> BlitCOLORKEY) Then PPCollision = True
'We have Pixel Perfect Collision
If PPCollision = True Then
CheckForPPCollision = True
Exit For 'Exit because we don't need to check anymore, we already have pixel perfect collision
End If
Next j
If PPCollision = True Then
CheckForPPCollision = True
Exit For 'Exit because we don't need to check anymore, we already have pixel perfect collision
End If
Next i
'Unlock the sufaces
DDSurf1.Unlock RECT1Overlap 'unlock DDsurf1
DDSurf2.Unlock RECT2Overlap 'Unlock DDSurf2
End If
End Function
Private Sub Terminate()
ProgRunning = False 'Stop the MainLoop
DD7.RestoreDisplayMode 'Restore display mode
DD7.SetCooperativeLevel 0, DDSCL_NORMAL 'Restore CooperativeLevel to Normal
'Kill the surfaces
Set MovingObj = Nothing
Set CenterObj = Nothing
Set BackBuffer = Nothing
Set Primary = Nothing
Set DD7 = Nothing 'Kill DirectDraw
Unload Me 'Unload Form
End Sub
|
|
发表于 2006-8-13 16:23:00
