Option Explicit

Private Const Pi             As Double = 3.14159265358979
Private Const DegToRadFaktor As Double = 1.74532925199433E-02
Private Const RadToDegFaktor As Double = 57.2957795130824

Public Sub DegToRad(Degrees As Double, lpRad As Double)
  lpRad = Degrees * DegToRadFaktor
End Sub

Public Sub RadToDeg(Rad As Double, lpDegrees As Double)
  lpDegrees = Rad * RadToDegFaktor
End Sub

Public Sub GetDistance(x1 As Long, y1 As Long, x2 As Long, _
      y2 As Long, lpDistance As Long)
  Dim DistX As Long
  Dim DistY As Long

  DistX = Abs(x1 - x2)
  DistY = Abs(y1 - y2)

  If DistX = 0 Then
    lpDistance = DistY
  ElseIf DistY = 0 Then
    lpDistance = DistX
  Else
    lpDistance = Sqr(DistX * DistX + DistY * DistY)
  End If
End Sub

Public Sub MoveX(Alpha As Double, Distance As Long, _
      lpMoveX As Long)
  Dim Rad As Double
 
  DegToRad Alpha, Rad
  lpMoveX = Cos(Rad) * Distance
End Sub

Public Sub MoveY(Alpha As Double, Distance As Long, _
      lpMoveY As Long)
  Dim Rad As Double

  DegToRad Alpha, Rad
  lpMoveY = Sin(Rad) * -Distance
End Sub

Option Explicit
 
Private Const MULTIPLIKATOR   As Byte = 255
 
Private Const STD_GRAVITATION As Long = 400
Private Const STD_SPEED       As Long = 10
Private Const STD_COLOR       As Long = 0
Private Const STD_MAXDIST     As Long = 500

Type Partikel
  fx      As Long
  fy      As Long
  MaxDist As Long
  bx      As Long
  by      As Long
  X       As Long
  Y       As Long
  Color   As Long
End Type

Type PartikelSystem
  Count      As Long
  Teilchen() As Partikel
End Type

Public Sub CreatePartikelSystem(lpPS As PartikelSystem)
  ReDim lpPS.Teilchen(0)
End Sub

Public Sub CreatePartikel(lpPS As PartikelSystem, X As Long, _
      Y As Long, Richtung As Double, Optional Color As Long = _
      STD_COLOR, Optional Speed As Long = STD_SPEED, Optional _
      MaxDist As Long = STD_MAXDIST)

  With lpPS
    .Count = .Count + 1
    ReDim Preserve .Teilchen(.Count)

    With .Teilchen(.Count)
      .X = X * MULTIPLIKATOR
      .Y = Y * MULTIPLIKATOR

      MoveX Richtung, Speed * MULTIPLIKATOR, .bx
      MoveY Richtung, Speed * MULTIPLIKATOR, .by

      .Color = Color
      .MaxDist = MaxDist * MULTIPLIKATOR
    End With
  End With
End Sub

Public Sub DeletePartikel(lpPS As PartikelSystem, index As Long)
  If index < 0 Or index > lpPS.Count Then Exit Sub

  Dim i As Long
  For i = index To lpPS.Count - 1
    lpPS.Teilchen(i) = lpPS.Teilchen(i + 1)
  Next i

  lpPS.Count = lpPS.Count - 1
  ReDim Preserve lpPS.Teilchen(lpPS.Count)
End Sub

Public Sub UpdatePartikelSystem(lpPS As PartikelSystem, _
      Optional Gravitation = STD_GRAVITATION)

  Dim verschiebung As Long
  Dim i As Long
  Dim index As Long
  Dim Distance As Long
  Dim Count As Long

  Count = lpPS.Count

  For i = 1 To Count
    index = i - verschiebung

    lpPS.Teilchen(index).fx = _
          lpPS.Teilchen(index).fx + lpPS.Teilchen(index).bx
    lpPS.Teilchen(index).fy = _
          lpPS.Teilchen(index).fy + lpPS.Teilchen(index).by

    lpPS.Teilchen(index).X = _
          lpPS.Teilchen(index).X + lpPS.Teilchen(index).bx
    lpPS.Teilchen(index).Y = _
          lpPS.Teilchen(index).Y + lpPS.Teilchen(index).by

    lpPS.Teilchen(index).by = lpPS.Teilchen(index).by + Gravitation

    GetDistance 0, 0, lpPS.Teilchen(index).fx \ MULTIPLIKATOR, _
          lpPS.Teilchen(index).fy \ MULTIPLIKATOR, Distance
    Distance = Distance * MULTIPLIKATOR

    If Distance > lpPS.Teilchen(index).MaxDist Then
      DeletePartikel lpPS, index
      verschiebung = verschiebung + 1
    End If
  Next i
End Sub

Public Sub RenderPartikel(PS As PartikelSystem)
  Dim i As Long

  For i = 1 To PS.Count
    With PS.Teilchen(i)
      MalePunkt .X \ MULTIPLIKATOR, .Y \ MULTIPLIKATOR, .Color
    End With
  Next i
End Sub

Private Sub MalePunkt(X As Long, Y As Long, Color As Long)
  frmPartikel.PSet (X, Y), Color
End Sub

Public Sub CreateExplosion(lpPS As PartikelSystem, _
      X As Long, Y As Long, Dichte As Long, _
      Optional Speed As Long = STD_SPEED, _
      Optional MinDistance As Long = STD_MAXDIST, _
      Optional MaxDistance As Long = STD_MAXDIST, _
      Optional ColorMin As Long = 0, _
      Optional ColorMax As Long = 16777215, _
      Optional Zufall As Boolean = True)

  If Dichte < 3 Then Exit Sub

  Dim i As Long

  If Zufall Then
    For i = 1 To Dichte
      CreatePartikel lpPS, X, Y, Rnd * 360 + 1, _
            CLng((ColorMax - ColorMin + 1) * Rnd + ColorMin), _
            Speed, CLng((MaxDistance - MinDistance + 1) * _
            Rnd + MinDistance)
    Next i

  Else
    Dim Faktor As Single

    Faktor = 360 / Dichte
    For i = 1 To Dichte
      CreatePartikel lpPS, X, Y, i * Faktor, _
            CLng((ColorMax - ColorMin + 1) * Rnd + ColorMin), _
            Speed, CLng((MaxDistance - MinDistance + 1) * _
            Rnd + MinDistance)
    Next i
  End If
End Sub

Option Explicit

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

Private Const WAITTIME = 1000

Private Const PARTIKEL_COUNT     As Long = 5
Private Const PARTIKEL_FLY_DIST  As Long = 1000
Private Const PARTIKEL_SPEED     As Long = 7

Private Const MOUSE_COUNT        As Long = 20
Private Const MOUSE_SPEED        As Long = 15
Private Const MOUSE_MINCOLOR     As Long = 64
Private Const MOUSE_MAXCOLOR     As Long = 255
Private Const MOUSE_MIN_FLY_DIST As Long = 100
Private Const MOUSE_MAX_FLY_DIST As Long = 1000

Dim running As Boolean
Dim Gravitation As Long
Dim AddDown As Boolean
Dim SubDown As Boolean

Private Const SLOW_DOWN As Long = 10

Dim FPS As Long
Dim LastTime As Long
Dim FPSCounter As Long

Dim mx As Long
Dim my As Long
Dim MDown As Boolean

Dim ParSys As PartikelSystem

Private Sub Form_Load()
  Dim i As Long
  Dim LoopStartTime As Long
 
  Me.Show
  Me.Refresh

  CreatePartikelSystem ParSys
  Gravitation = 400

  running = True

  Do While running
    LoopStartTime = GetTickCount
    Cls

    For i = 1 To PARTIKEL_COUNT
      CreatePartikel ParSys, Rnd * ScaleWidth + 1, _
          Rnd * ScaleHeight + 1, Rnd * 360 + 1, _
          RGB(128 + Rnd * 128, 128 + Rnd * 255, 128 + Rnd * 255), _
          PARTIKEL_SPEED, PARTIKEL_FLY_DIST
    Next i

    CreateExplosion ParSys, mx, my, MOUSE_COUNT, MOUSE_SPEED, _
        MOUSE_MIN_FLY_DIST, MOUSE_MAX_FLY_DIST, MOUSE_MINCOLOR, _
        MOUSE_MAXCOLOR

    If MDown Then MouseDownEffect

    UpdatePartikelSystem ParSys, Gravitation
    RenderPartikel ParSys

    lblPartikelCount = ParSys.Count

    If AddDown Then Gravitation = Gravitation + 10
    If SubDown Then Gravitation = Gravitation - 10

    lblGrav = Gravitation
    CalculateFPS

    While GetTickCount - LoopStartTime < SLOW_DOWN: Wend
    DoEvents
  Loop

  End
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Select Case KeyCode
    Case vbKeyEscape: running = False
    Case vbKeyAdd: AddDown = True
    Case vbKeySubtract: SubDown = True
  End Select
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  Select Case KeyCode
    Case vbKeyAdd: AddDown = False
    Case vbKeySubtract: SubDown = False
  End Select
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  mx = X
  my = Y
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  MDown = True
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  MDown = False
End Sub

Private Sub MouseDownEffect()
  Dim Blue As Long

  Blue = RGB(0, 0, 255)

  CreatePartikel ParSys, mx + (Rnd * 100 + 1) - 100, my, 60, _
        Blue, 70, 7000
  CreatePartikel ParSys, mx + (Rnd * 100 + 1) - 100, my, 120, _
        Blue, 70, 7000
  CreatePartikel ParSys, mx + (Rnd * 100 + 1) - 100, my, 60, _
        Blue, 70, 7000
End Sub

Private Sub CalculateFPS()
  FPSCounter = FPSCounter + 1
  If GetTickCount - LastTime >= WAITTIME Then
    FPS = 1000 / WAITTIME * FPSCounter
    LastTime = GetTickCount
    FPSCounter = 0
    lblFps = FPS
  End If
End Sub

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