Option Explicit

Private Declare Function IntersectRect Lib "user32" (lpDestRect _
        As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long

Dim mdx As New DirectX7
Dim mdd As DirectDraw7
Dim msurfFront As DirectDrawSurface7
Dim msurfBack As DirectDrawSurface7
Dim msurfCenterObj As DirectDrawSurface7
Dim msurfMovingObj As DirectDrawSurface7

Const SCREEN_WIDTH = 640
Const SCREEN_HEIGHT = 480
Const SCREEN_BITDEPTH = 8
Const OBJECT_WIDTH = 100
Const OBJECT_HEIGHT = 100
Const MOVE_SPEED = 1
Const COLOUR_KEY = 0

Dim mrectScreen As RECT
Dim mrectSource As RECT

Dim mintX As Integer
Dim mintY As Integer
Dim mblnLeftKey As Boolean
Dim mblnRightKey As Boolean
Dim mblnDownKey As Boolean
Dim mblnUpKey As Boolean

Dim mblnRunning As Boolean
Dim mlngTimer As Long
Dim mintFPSCounter As Integer
Dim mintFPS As Integer

Private Sub Form_Load()
  Dim ddsdMain As DDSURFACEDESC2
  Dim ddsdFlip As DDSURFACEDESC2
  Dim ddsdObjects As DDSURFACEDESC2
  Dim ckeyColour As DDCOLORKEY
  Dim i As Integer
  Dim j As Integer

  Me.Show

  Set mdd = mdx.DirectDrawCreate("")

  mdd.SetCooperativeLevel frmMain.hWnd, DDSCL_FULLSCREEN Or _
        DDSCL_EXCLUSIVE
  mdd.SetDisplayMode SCREEN_WIDTH, SCREEN_HEIGHT, _
        SCREEN_BITDEPTH, 0, DDSDM_DEFAULT

  ddsdMain.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  ddsdMain.lBackBufferCount = 1
  ddsdMain.ddsCaps.lCaps = DDSCAPS_COMPLEX Or DDSCAPS_FLIP Or _
        DDSCAPS_PRIMARYSURFACE

  Set msurfFront = mdd.CreateSurface(ddsdMain)

  ddsdFlip.ddsCaps.lCaps = DDSCAPS_BACKBUFFER
  Set msurfBack = msurfFront.GetAttachedSurface(ddsdFlip.ddsCaps)

  msurfBack.SetForeColor vbWhite
  msurfBack.SetFontTransparency True

  ddsdObjects.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  ddsdObjects.ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY Or _
     DDSCAPS_OFFSCREENPLAIN
  ddsdObjects.lHeight = OBJECT_HEIGHT
  ddsdObjects.lWidth = OBJECT_WIDTH
  Set msurfCenterObj = mdd.CreateSurfaceFromFile(App.Path & _
         "\center.bmp", ddsdObjects)
  Set msurfMovingObj = mdd.CreateSurfaceFromFile(App.Path & _
         "\moving.bmp", ddsdObjects)
  ckeyColour.high = COLOUR_KEY
  ckeyColour.low = COLOUR_KEY
  msurfCenterObj.SetColorKey DDCKEY_SRCBLT, ckeyColour
  msurfMovingObj.SetColorKey DDCKEY_SRCBLT, ckeyColour

  mrectSource.Bottom = OBJECT_HEIGHT
  mrectSource.Right = OBJECT_WIDTH

  mrectScreen.Bottom = SCREEN_HEIGHT
  mrectScreen.Right = SCREEN_WIDTH

  MainLoop
End Sub

Private Sub MainLoop()
  Dim i As Integer
  Dim j As Integer
  Dim rectCenter As RECT
  Dim rectMoving As RECT
  Dim rectOverlap As RECT
  Dim rectMovingOverlap As RECT
  Dim rectCenterOverlap As RECT
  Dim ddsdBlank As DDSURFACEDESC2
  Dim intWidth As Integer
  Dim intHeight As Integer
  Dim bytCenter() As Byte
  Dim bytMoving() As Byte
  Dim blnPPCollision As Boolean

  mblnRunning = True

  Do While mblnRunning

    msurfBack.BltColorFill mrectScreen, 0

    With rectCenter
      .Left = (SCREEN_WIDTH \ 2) - (OBJECT_WIDTH \ 2)
      .Right = .Left + OBJECT_WIDTH
      .Top = (SCREEN_HEIGHT \ 2) - (OBJECT_HEIGHT \ 2)
      .Bottom = .Top + OBJECT_WIDTH
      msurfBack.BltFast .Left, .Top, msurfCenterObj, _
      mrectSource, DDBLTFAST_WAIT
    End With

    MoveObject

    With rectMoving
      .Left = mintX
      .Right = mintX + OBJECT_WIDTH
      .Top = mintY
      .Bottom = mintY + OBJECT_WIDTH
      msurfBack.BltFast .Left, .Top, msurfMovingObj, _
          mrectSource, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
    End With

    If IntersectRect(rectOverlap, rectCenter, rectMoving) Then
          msurfBack.DrawText 0, 70, "Rechteck Kollision", False

    With rectMovingOverlap
      .Top = rectOverlap.Top - rectMoving.Top
      .Bottom = rectOverlap.Bottom - rectMoving.Top
      .Left = rectOverlap.Left - rectMoving.Left
      .Right = rectOverlap.Right - rectMoving.Left
    End With

    With rectCenterOverlap
      .Top = rectOverlap.Top - rectCenter.Top
      .Bottom = rectOverlap.Bottom - rectCenter.Top
      .Left = rectOverlap.Left - rectCenter.Left
      .Right = rectOverlap.Right - rectCenter.Left
    End With

    intWidth = rectOverlap.Right - rectOverlap.Left - 1
    intHeight = rectOverlap.Bottom - rectOverlap.Top - 1

    msurfMovingObj.Lock rectMovingOverlap, ddsdBlank, _
          LOCK_READONLY Or DDLOCK_WAIT, 0
    msurfMovingObj.GetLockedArray bytMoving
    msurfCenterObj.Lock rectCenterOverlap, ddsdBlank, _
          DDLOCK_READONLY Or DDLOCK_WAIT, 0
    msurfCenterObj.GetLockedArray bytCenter

    blnPPCollision = False

    For i = 0 To intWidth
      For j = 0 To intHeight
        If (bytMoving(i + rectMovingOverlap.Left, j + _
            rectMovingOverlap.Top) <> COLOUR_KEY) And _
            (bytCenter(i + rectCenterOverlap.Left, j + _
            rectCenterOverlap.Top) <> COLOUR_KEY) Then _
                  blnPPCollision = True
        If blnPPCollision = True Then Exit For
      Next j
      If blnPPCollision = True Then Exit For
    Next i

    msurfCenterObj.Unlock rectCenterOverlap
    msurfMovingObj.Unlock rectMovingOverlap

    If blnPPCollision = True Then msurfBack.DrawText 0, 85, _
           "Pixelgenaue Kollision!", False

    End If

    FPS
    msurfFront.Flip Nothing, DDFLIP_WAIT
    DoEvents
  Loop
End Sub

Private Sub FPS()
  If mlngTimer + 1000 <= mdx.TickCount Then
    mlngTimer = mdx.TickCount
    mintFPS = mintFPSCounter + 1
    mintFPSCounter = 0
  Else
    mintFPSCounter = mintFPSCounter + 1
  End If

  msurfBack.DrawText 0, 0, "Cursortasten zum Bewegen, " & _
      "ESC Beenden. Aktuelle FPS: " & mintFPS, False
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyLeft Then mblnLeftKey = True
  If KeyCode = vbKeyRight Then mblnRightKey = True
  If KeyCode = vbKeyUp Then mblnUpKey = True
  If KeyCode = vbKeyDown Then mblnDownKey = True
  If KeyCode = vbKeyEscape Then Terminate
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyLeft Then mblnLeftKey = False
  If KeyCode = vbKeyRight Then mblnRightKey = False
  If KeyCode = vbKeyUp Then mblnUpKey = False
  If KeyCode = vbKeyDown Then mblnDownKey = False
End Sub

Private Sub MoveObject()
  If mblnUpKey Then mintY = mintY - MOVE_SPEED
  If mblnDownKey Then mintY = mintY + MOVE_SPEED
  If mblnLeftKey Then mintX = mintX - MOVE_SPEED
  If mblnRightKey Then mintX = mintX + MOVE_SPEED
End Sub

Private Sub Terminate()
  mblnRunning = False
  mdd.RestoreDisplayMode
  mdd.SetCooperativeLevel 0, DDSCL_NORMAL

  Set msurfMovingObj = Nothing
  Set msurfCenterObj = Nothing
  Set msurfBack = Nothing
  Set msurfFront = Nothing

  Set mdd = Nothing
  Unload Me
End Sub