|
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
|
|