Tipp 0063 Massenträgheit & Anziehungskraft
Autor/Einsender:
Datum:
  Delta Konzept
23.05.2001
Entwicklungsumgebung:   VB 5
Vor allem für die Spielprogrammierung ohne DirectX sehr interessant, demonstriert dieses Beispiel sehr schön anhand eines virtuellen Planetensystems, wie sich mit den VB-eigenen Grafikmethoden realistische Effekte, wie Anziehungskraft und Massenträgheit, realisieren lassen.
 
Option Explicit

Private Type Dot
  PosX As Double
  PosY As Double
  SpeedX As Double
  SpeedY As Double
  Mass As Double
  Radius As Double
End Type

Private Dots(4) As Dot
Private ViewPort As Long

Private myDrawMode As Long
Private Zeit

Private Sub Form_Load()
  Dim i As Long

  Randomize
  myDrawMode = 13

  For i = 0 To UBound(Dots)
    Dots(i).PosX = Int(Rnd(1) * Picture1(0).ScaleWidth)
    Dots(i).PosY = Int(Rnd(1) * Picture1(0).ScaleHeight)
    Dots(i).Radius = 6 + Rnd(1) * 20
    Dots(i).Mass = (Dots(i).Radius * 50) ^ 3
  Next i

  Dots(0).PosX = Picture1(0).ScaleWidth / 2 + 30
  Dots(0).PosY = Picture1(0).ScaleHeight / 2
  Dots(0).Radius = 28
  Dots(0).Mass = (Dots(0).Radius * 50) ^ 3
  Dots(0).SpeedY = 0.102

  Dots(1).PosX = Picture1(0).ScaleWidth / 4
  Dots(1).PosY = Picture1(0).ScaleHeight / 2
  Dots(1).Radius = 4.7
  Dots(1).Mass = (Dots(1).Radius * 50) ^ 3
  Dots(1).SpeedY = -1.6

  Dots(2).PosX = Picture1(0).ScaleWidth / 8 + _
      Picture1(0).ScaleWidth / 2
  Dots(2).PosY = Picture1(0).ScaleHeight / 2
  Dots(2).Radius = 5
  Dots(2).Mass = (Dots(2).Radius * 50) ^ 3
  Dots(2).SpeedY = 2.15

  Dots(3).PosX = Picture1(0).ScaleWidth / 2
  Dots(3).PosY = Picture1(0).ScaleHeight / 16
  Dots(3).Radius = 3
  Dots(3).Mass = (Dots(3).Radius * 50) ^ 3
  Dots(3).SpeedX = 2.2

  Dots(4).PosX = Picture1(0).ScaleWidth / 2 - 30
  Dots(4).PosY = Picture1(0).ScaleHeight / 2
  Dots(4).Radius = 28
  Dots(4).Mass = (Dots(4).Radius * 50) ^ 3
  Dots(4).SpeedY = -0.102

  Load Picture1(1)
  Picture1(1).Visible = True
End Sub

Private Sub Form_Resize()
  Picture1(0).Top = 0
  Picture1(1).Top = 0
  Picture1(0).Left = 0
  Picture1(1).Left = 0
  Picture1(0).Width = Form1.ScaleWidth
  Picture1(1).Width = Form1.ScaleWidth
  Picture1(0).Height = Form1.ScaleHeight
  Picture1(1).Height = Form1.ScaleHeight
End Sub

Private Sub Picture1_KeyPress(Index As Integer, _
      KeyAscii As Integer)
  If Chr$(KeyAscii) = "+" Then myDrawMode = myDrawMode + 1
  If Chr$(KeyAscii) = "-" Then myDrawMode = myDrawMode - 1
End Sub

Private Sub Timer1_Timer()
  Dim i As Long, n As Long
  Dim EntfernungX As Long, EntfernungY As Long
  Dim Entfernung As Long
  Dim Radius As Long

  On Local Error Resume Next

  For n = 0 To UBound(Dots)
    For i = 0 To UBound(Dots)
      If n <> i Then
        EntfernungX = Abs(Dots(n).PosX - Dots(i).PosX)
        EntfernungY = Abs(Dots(n).PosY - Dots(i).PosY)
        If EntfernungX + EntfernungY <> 0 Then
          If Dots(i).PosX > Dots(n).PosX Then
            Dots(i).SpeedX = Dots(i).SpeedX - (Dots(n).Mass / _
                ((EntfernungX + EntfernungY) ^ 2)) / Dots(i).Mass
          Else
            Dots(i).SpeedX = Dots(i).SpeedX + (Dots(n).Mass / _
                ((EntfernungX + EntfernungY) ^ 2)) / Dots(i).Mass
          End If
          If Dots(i).PosY > Dots(n).PosY Then
            Dots(i).SpeedY = Dots(i).SpeedY - (Dots(n).Mass / _
                ((EntfernungX + EntfernungY) ^ 2)) / Dots(i).Mass
          Else
            Dots(i).SpeedY = Dots(i).SpeedY + (Dots(n).Mass / _
                ((EntfernungX + EntfernungY) ^ 2)) / Dots(i).Mass
          End If
        End If

        Entfernung = EntfernungX ^ 2 + EntfernungY ^ 2
        Radius = (Dots(i).Radius + Dots(n).Radius) ^ 2
        If Entfernung <= Radius Then Call Stoss(i, n)
      End If
    Next i
  Next n

  If ViewPort = 0 Then
    Picture1(1).ZOrder 0
    ViewPort = 1
    For i = 0 To UBound(Dots)
      Picture1(0).Circle (Dots(i).PosX, Dots(i).PosY), _
          Dots(i).Radius, RGB(0, 0, 0)
    Next i
  Else
    Picture1(0).ZOrder 0
    ViewPort = 0
    For i = 0 To UBound(Dots)
      Picture1(1).Circle (Dots(i).PosX, Dots(i).PosY), _
          Dots(i).Radius, RGB(0, 0, 0)
    Next i
  End If

  For i = 0 To UBound(Dots)
    Dots(i).PosX = Dots(i).PosX + Dots(i).SpeedX
    If Dots(i).PosX < 0 Or Dots(i).PosX > Picture1(0).ScaleWidth _
        Then Dots(i).SpeedX = Dots(i).SpeedX * -1
    Dots(i).PosY = Dots(i).PosY + Dots(i).SpeedY
    If Dots(i).PosY < 0 Or Dots(i).PosY > Picture1(0).ScaleHeight _
        Then Dots(i).SpeedY = Dots(i).SpeedY * -1
  Next i

  If ViewPort = 0 Then
    For i = 0 To UBound(Dots)
      Picture1(0).Circle (Dots(i).PosX, Dots(i).PosY), _
          Dots(i).Radius, RGB(255, 255, 255)
    Next i
    Me.Caption = "fps:" & Format(1 / (Timer - Zeit), "#0.0")
    Zeit = Timer
  Else
    For i = 0 To UBound(Dots)
      Picture1(1).Circle (Dots(i).PosX, Dots(i).PosY), _
          Dots(i).Radius, RGB(255, 255, 255)
    Next i
    Me.Caption = "fps:" & Format(1 / (Timer - Zeit), "#0.0")
    On Error GoTo 0
    Zeit = Timer
  End If
End Sub

Sub Stoss(i, n)
  Dim u1x#, u1y#, u1x_#, u1y_#, u2x_#, u2y_#
  Dim mr#, rx#, ry#, r_2#, d1#

  rx = Dots(n).PosX - Dots(i).PosX
  ry = Dots(n).PosY - Dots(i).PosY
  r_2 = rx * rx + ry * ry
  mr = Dots(n).Mass / Dots(i).Mass
  u1x = Dots(i).SpeedX - Dots(n).SpeedX
  u1y = Dots(i).SpeedY - Dots(n).SpeedY
  d1 = 2 * (u1x * rx + u1y * ry) / ((mr + 1) * r_2)

  If d1 < 0 Then Exit Sub

  u2x_ = rx * d1
  u2y_ = ry * d1
  u1x_ = u1x - mr * u2x_
  u1y_ = u1y - mr * u2y_
  Dots(i).SpeedX = u1x_ + Dots(n).SpeedX
  Dots(i).SpeedY = u1y_ + Dots(n).SpeedY
  Dots(n).SpeedX = u2x_ + Dots(n).SpeedX
  Dots(n).SpeedY = u2y_ + Dots(n).SpeedY
End Sub

Private Sub DrawLight(PosX, PosY, Size, Dest As Control)
  Dim Factor As Double, X As Long, Y As Long, RGB As Long
  Dim R As Long, B As Long, G As Long
  Factor = Picture2.ScaleWidth / (Size * 4)
  For X = 0 To Size * 4 - 4
    For Y = 0 To Size * 4 - 4
      RGB = Picture2.Point(X * Factor, Y * Factor)
      B = (RGB And &HFF0000) / &H10000
      G = (RGB And &HFF00&) / &H100&
      R = (RGB And &HFF&)
      RGB = Dest.Point(PosX - Size * 2 + X, PosY - Size * 2 + Y)
      B = (RGB And &HFF0000) / &H10000 + B
      G = (RGB And &HFF00&) / &H100& + G
      R = (RGB And &HFF&) + R
      If B > 255 Then B = 255
      If G > 255 Then G = 255
      If R > 255 Then R = 255
      RGB = B * &H10000 + G * &H100& + R
      Dest.PSet (PosX - Size * 2 + X, PosY - Size * 2 + Y), RGB
    Next Y
  Next X
End Sub
 

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (11,6 kB) Downloads bisher: [ 2744 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Mittwoch, 31. August 2011