Option Explicit

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetTickCount Lib "kernel32" () As Long

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

Const MS_DELAY = 10
Const RADIUS1 = 30
Const RADIUS2 = 20
Const RECT_WIDTH = 80
Const RECT_HEIGHT = 60

Dim msngCircle1X As Single
Dim msngCircle1Y As Single
Dim msngCircle2X As Single
Dim msngCircle2Y As Single
Dim mudtRect1 As RECT
Dim mudtRect2 As RECT

Dim mblnCircles As Boolean
Dim mblnRects As Boolean
Dim mblnCollision As Boolean

Dim mlngTimer As Long
Dim mblnRunning As Boolean
Dim mblnLeftKey As Boolean
Dim mblnRightKey As Boolean
Dim mblnDownKey As Boolean
Dim mblnUpKey As Boolean

Private Sub Form_Load()
  Randomize
  msngCircle1X = Rnd() * frmMain.ScaleWidth
  msngCircle1Y = Rnd() * frmMain.ScaleHeight
  msngCircle2X = Rnd() * frmMain.ScaleWidth
  msngCircle2Y = Rnd() * frmMain.ScaleHeight

  With mudtRect1
    .Top = Rnd() * frmMain.ScaleHeight
    .Left = Rnd() * frmMain.ScaleWidth
    .Bottom = .Top + RECT_HEIGHT
    .Right = .Left + RECT_WIDTH
  End With

  With mudtRect2
    .Top = Rnd() * frmMain.ScaleHeight
    .Left = Rnd() * frmMain.ScaleWidth
    .Bottom = .Top + RECT_HEIGHT
    .Right = .Left + RECT_WIDTH
  End With

  mblnRects = True

  Me.Show

  MsgBox "Mit den Cursortasten wird das Objekt bewegt," & _
     vbCrLf & vbCrLf & _
     "mit ENTER werden die Objekte gewechselt und" & vbCrLf & _
     vbCrLf & "mit ESC das Beispiel verlassen.", _
     vbOKOnly, "Kollision"

  mblnRunning = True

  Do While mblnRunning
    If mlngTimer + MS_DELAY <= GetTickCount() Then
      mlngTimer = GetTickCount()
      frmMain.Cls
      If mblnCircles Then
        CircleCollision
        MoveCircle
        DrawCircle msngCircle1X, msngCircle1Y, RADIUS1, vbWhite
        If mblnCollision Then
          DrawCircle msngCircle2X, msngCircle2Y, RADIUS2, vbRed
        Else
          DrawCircle msngCircle2X, msngCircle2Y, RADIUS2, vbWhite
        End If
      ElseIf mblnRects Then
        RectCollision
        MoveRect
        DrawRect mudtRect1, vbWhite
        If mblnCollision Then
           DrawRect mudtRect2, vbRed
        Else
           DrawRect mudtRect2, vbWhite
        End If
      End If
    End If
    DoEvents
  Loop
End Sub

Private Sub MoveCircle()
  If mblnDownKey = True Then msngCircle1Y = msngCircle1Y + 1
  If mblnUpKey = True Then msngCircle1Y = msngCircle1Y - 1
  If mblnLeftKey = True Then msngCircle1X = msngCircle1X - 1
  If mblnRightKey = True Then msngCircle1X = msngCircle1X + 1
End Sub

Private Sub MoveRect()
  With mudtRect1
    If mblnDownKey = True Then
      .Top = .Top + 1
      .Bottom = .Bottom + 1
    End If
    If mblnUpKey = True Then
      .Top = .Top - 1
      .Bottom = .Bottom - 1
    End If
    If mblnLeftKey = True Then
      .Left = .Left - 1
      .Right = .Right - 1
    End If
    If mblnRightKey = True Then
      .Left = .Left + 1
      .Right = .Right + 1
    End If
  End With
End Sub

Private Sub CircleCollision()
  mblnCollision = GetDist(msngCircle1X, msngCircle1Y, _
      msngCircle2X, msngCircle2Y) <= RADIUS1 + RADIUS2
End Sub

Private Sub RectCollision()
  Dim udtTempRect As RECT

  mblnCollision = IntersectRect(udtTempRect, mudtRect1, mudtRect2)
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 = vbKeyReturn Then
    mblnCircles = Not (mblnCircles)
    mblnRects = Not (mblnRects)
  End If
  If KeyCode = vbKeyEscape Then Unload Me
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 DrawRect(rectSource As RECT, lngColour As Long)
  Line (rectSource.Left, rectSource.Top)-(rectSource.Left, _
     rectSource.Bottom), lngColour
  Line (rectSource.Left, rectSource.Top)-(rectSource.Right, _
     rectSource.Top), lngColour
  Line (rectSource.Right, rectSource.Bottom)-(rectSource.Right, _
     rectSource.Top), lngColour
  Line (rectSource.Right, rectSource.Bottom)-(rectSource.Left, _
     rectSource.Bottom), lngColour
End Sub

Private Sub DrawCircle(sngX As Single, sngY As Single, _
      sngRadius As Single, lngColour As Long)
  Circle (sngX, sngY), sngRadius, lngColour
End Sub

Private Function GetDist(intX1 As Single, intY1 As Single, _
      intX2 As Single, intY2 As Single) As Single

  GetDist = Sqr((intX1 - intX2) ^ 2 + (intY1 - intY2) ^ 2)
End Function

Private Sub Form_Unload(Cancel As Integer)
  mblnRunning = False
  End
End Sub