|
Option Explicit
Dim DX7 As New DirectX7
Dim DD7 As DirectDraw7
Dim SurfaceDesc As DDSURFACEDESC2
Dim PrimarySurface As DirectDrawSurface7
Dim ddPF As DDPIXELFORMAT
Dim BackBuffer As DirectDrawSurface7
Dim bmpBild1 As DirectDrawSurface7
Dim bolKollision As Boolean
Dim running As Boolean
Dim FPSCounter As Single
Dim FPS As Single
Dim FPSTickLast As Long
Private Sub Form_Load()
Dim Destrect As RECT
Dim SrcRect As RECT
Dim i As Single
Dim hlpAngle As Double
Me.Show
Me.Refresh
Initialization
BitmapLaden
SetPI
BILD(0).X = 250: BILD(0).Y = 10: _
BILD(0).DirX = 1: BILD(0).DirY = 1
BILD(1).X = 50: BILD(1).Y = 200: _
BILD(1).DirX = 0.5: BILD(1).DirY = 1
BILD(2).X = 300: BILD(2).Y = 400: _
BILD(2).DirX = 1: BILD(2).DirY = 0.5
running = True
Do
For i = 0 To 2
If BILD(i).X < 5 Then
BILD(i).DirX = BILD(i).DirX * -1
End If
If BILD(i).Y < 5 Then
BILD(i).DirY = BILD(i).DirY * -1
End If
If BILD(i).X + 10 > (SCREENWIDTH - BildBreiteHoehe) Then
BILD(i).DirX = BILD(i).DirX * -1
End If
If BILD(i).Y + 10 > (SCREENHEIGHT - BildBreiteHoehe) Then
BILD(i).DirY = BILD(i).DirY * -1
End If
BILD(i).X = BILD(i).X + BILD(i).DirX
BILD(i).Y = BILD(i).Y + BILD(i).DirY
With SrcRect
.Left = 0: .Right = BildBreiteHoehe
.Top = 0: .Bottom = BildBreiteHoehe
End With
BackBuffer.BltFast BILD(i).X, BILD(i).Y, bmpBild1, _
SrcRect, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
Next i
bolKollision = False
If GetDistance(BILD(0).X + 33, BILD(0).Y + 33, _
BILD(1).X + 33, BILD(1).Y + 33) <= 66 Then
bolKollision = True
hlpAngle = GetAngle(BILD(0).X + 33, BILD(0).Y + 33, _
BILD(1).X + 33, BILD(1).Y + 33)
BILD(0).DirX = (Sin(DegToRad(hlpAngle)) * -1) * 5
BILD(0).DirY = (-Cos(DegToRad(hlpAngle)) * -1) * 5
hlpAngle = GetAngle(BILD(1).X + 33, BILD(1).Y + 33, _
BILD(0).X + 33, BILD(0).Y + 33)
BILD(1).DirX = (Sin(DegToRad(hlpAngle)) * -1) * 5
BILD(1).DirY = (-Cos(DegToRad(hlpAngle)) * -1) * 5
End If
If GetDistance(BILD(0).X + 33, BILD(0).Y + 33, _
BILD(2).X + 33, BILD(2).Y + 33) <= 66 Then
bolKollision = True
hlpAngle = GetAngle(BILD(0).X + 33, BILD(0).Y + 33, _
BILD(2).X + 33, BILD(2).Y + 33)
BILD(0).DirX = (Sin(DegToRad(hlpAngle)) * -1) * 5
BILD(0).DirY = (-Cos(DegToRad(hlpAngle)) * -1) * 5
hlpAngle = GetAngle(BILD(2).X + 33, BILD(2).Y + 33, _
BILD(0).X + 33, BILD(0).Y + 33)
BILD(2).DirX = (Sin(DegToRad(hlpAngle)) * -1) * 5
BILD(2).DirY = (-Cos(DegToRad(hlpAngle)) * -1) * 5
End If
If GetDistance(BILD(1).X + 33, BILD(1).Y + 33, _
BILD(2).X + 33, BILD(2).Y + 33) <= 66 Then
bolKollision = True
hlpAngle = GetAngle(BILD(1).X + 33, BILD(1).Y + 33, _
BILD(2).X + 33, BILD(2).Y + 33)
BILD(1).DirX = (Sin(DegToRad(hlpAngle)) * -1) * 5
BILD(1).DirY = (-Cos(DegToRad(hlpAngle)) * -1) * 5
hlpAngle = GetAngle(BILD(2).X + 33, BILD(2).Y + 33, _
BILD(1).X + 33, BILD(1).Y + 33)
BILD(2).DirX = (Sin(DegToRad(hlpAngle)) * -1) * 5
BILD(2).DirY = (-Cos(DegToRad(hlpAngle)) * -1) * 5
End If
BackBuffer.SetForeColor vbRed
BackBuffer.SetFont Me.Font
BackBuffer.DrawText 10, 10, "DirectDraw und Bitmaps-" & _
"Kollisionsüberprüfung via Distanzberechnung", False
BackBuffer.DrawText _
10, 30, "<Esc> beendet das Programm", False
BackBuffer.DrawText _
10, 50, "FPS: " & Format(FPS, "0.0"), False
If bolKollision Then
BackBuffer.DrawText 10, 70, "Kollision", False
End If
PrimarySurface.Flip Nothing, DDFLIP_WAIT
ClearBuffer vbBlack
If FPSCounter = 30 Then
If FPSTickLast <> 0 Then _
FPS = 1000 * 30 / (GetTime - FPSTickLast) + 1
FPSTickLast = GetTime
FPSCounter = 0
End If
FPSCounter = FPSCounter + 1
DoEvents
Loop While running
Terminate
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If (KeyAscii = vbKeyEscape) Then
running = False
End If
End Sub
Sub Initialization()
Set DD7 = DX7.DirectDrawCreate("")
DD7.SetCooperativeLevel Me.hWnd, DDSCL_EXCLUSIVE Or _
DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT
DD7.SetDisplayMode SCREENWIDTH, SCREENHEIGHT, 16, 0, _
DDSDM_DEFAULT
With SurfaceDesc
.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or _
DDSCAPS_FLIP Or DDSCAPS_COMPLEX
.lBackBufferCount = 1
End With
Set PrimarySurface = DD7.CreateSurface(SurfaceDesc)
SurfaceDesc.ddsCaps.lCaps = DDSCAPS_BACKBUFFER
Set BackBuffer = _
PrimarySurface.GetAttachedSurface(SurfaceDesc.ddsCaps)
PrimarySurface.GetPixelFormat ddPF
End Sub
Sub BitmapLaden()
Dim ColorKey As DDCOLORKEY
Dim BmpDesc As DDSURFACEDESC2
BmpDesc.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
BmpDesc.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
BmpDesc.lWidth = 66: BmpDesc.lHeight = 66
Set bmpBild1 = _
DD7.CreateSurfaceFromFile(App.Path & "\Objekt.bmp", BmpDesc)
ColorKey.high = (ddPF.lRBitMask + ddPF.lBBitMask)
ColorKey.low = (ddPF.lRBitMask + ddPF.lBBitMask)
bmpBild1.SetColorKey DDCKEY_SRCBLT, ColorKey
End Sub
Sub Terminate()
Set bmpBild1 = Nothing
DD7.RestoreDisplayMode
DD7.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
Set PrimarySurface = Nothing
Set DD7 = Nothing
Set DX7 = Nothing
End
End Sub
Sub ClearBuffer(Color As Long)
Dim Destrect As RECT
With Destrect
.Bottom = SCREENHEIGHT
.Left = 0
.Right = SCREENWIDTH
.Top = 0
End With
BackBuffer.BltColorFill Destrect, Color
End Sub
Function GetTime() As Long
GetTime = DX7.TickCount
End Function
|
|