Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH5/SRC/PLANETS.FRM

Visual Basic Form | 1996-05-02 | 8.3 KB | 280 lines

VERSION 4.00
Begin VB.Form PlanetForm
   Caption         =   "Planets"
   ClientHeight    =   5775
   ClientLeft      =   1590
   ClientTop       =   735
   ClientWidth     =   6015
   Height          =   6465
   Left            =   1530
   LinkTopic       =   "Form1"
   ScaleHeight     =   385
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   401
   Top             =   105
   Width           =   6135
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   1560
      TabIndex        =   3
      Text            =   "20"
      Top             =   5400
      Width           =   375
   End
   Begin VB.CommandButton CmdRun
      Caption         =   "Run"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   495
      Left            =   2160
      TabIndex        =   1
      Top             =   5280
      Width           =   855
   End
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      FillStyle       =   0  'Solid
      Height          =   5250
      Left            =   0
      Picture         =   "PLANETS.frx":0000
      ScaleHeight     =   346
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   396
      TabIndex        =   0
      Top             =   0
      Width           =   6000
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   3120
      Top             =   5280
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "Frames per second:"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   5400
      Width           =   1455
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "PlanetForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim Playing As Boolean
Dim NumPlanets As Integer
Dim Cx() As Double          ' Position.
Dim Cy() As Double
Dim Vx() As Double          ' Velocity.
Dim Vy() As Double
Dim M() As Double           ' Mass.
Dim R() As Double           ' Radius.
Dim Clr() As Long           ' Colors.
' ************************************************
' Pause a little while.
' ************************************************
Sub Delay(interval As Double)
Dim start_time As Double
    start_time = Timer
    Do While Timer - start_time < interval
        DoEvents
    Loop
End Sub
' ************************************************
' Load the data in a planet file.
' ************************************************
Sub LoadPlanets(fname As String)
Dim fnum As Integer
Dim i As Integer
Dim old_style As Integer
    fnum = FreeFile
    Open fname For Input As #fnum

    Input #fnum, NumPlanets
    ReDim Cx(1 To NumPlanets)
    ReDim Cy(1 To NumPlanets)
    ReDim Vx(1 To NumPlanets)
    ReDim Vy(1 To NumPlanets)
    ReDim M(1 To NumPlanets)
    ReDim R(1 To NumPlanets)
    ReDim Clr(1 To NumPlanets)
    For i = 1 To NumPlanets
        Input #fnum, _
            Cx(i), Cy(i), Vx(i), Vy(i), M(i), Clr(i)
        R(i) = Sqr(M(i)) + 1
    Next i

    Close #fnum
    ' Draw the planets.
    old_style = Canvas.FillStyle
    Canvas.FillStyle = vbSolid
    Canvas.Cls
    For i = 1 To NumPlanets
        Canvas.FillColor = Clr(i)
        Canvas.Circle (Cx(i), Cy(i)), R(i), Clr(i)
    Next i
    Canvas.FillStyle = old_style
    Caption = "Planets [" & fname & "]"
    CmdRun.Enabled = True
End Sub
' ************************************************
' Make the planets move until Playing is false.
' ************************************************
Sub PlaySimulation()
Const F_SCALE = 1000
Dim mpf As Long     ' Milliseconds per frame.
Dim next_time As Long
Dim old_style As Integer
Dim i As Integer
Dim j As Integer
Dim dx As Double
Dim dy As Double
Dim d2 As Double
Dim d As Double
Dim f As Double
Dim a_d As Double
    ' Set FillStyle to vbSolid.
    old_style = Canvas.FillStyle
    Canvas.FillStyle = vbSolid
    ' See how fast we should go.
    If Not IsNumeric(FPSText.Text) Then _
        FPSText.Text = "10"
    mpf = 1000 \ CLng(FPSText.Text)
    ' Start the animation.
    next_time = GetTickCount()
    Do While Playing
        ' Calculate the forces on the planets.
        For i = 1 To NumPlanets - 1
            For j = i + 1 To NumPlanets
                ' Calculate the force between planets
                ' i and j. Translate the force into a
                ' change in velocity.
                dx = Cx(i) - Cx(j)
                dy = Cy(i) - Cy(j)
                d2 = dx * dx + dy * dy
                f = F_SCALE * M(i) * M(j) / d2
                d = Sqr(d2)

                a_d = f / M(i) / d
                Vx(i) = Vx(i) - a_d * dx
                Vy(i) = Vy(i) - a_d * dy

                a_d = f / M(j) / d
                Vx(j) = Vx(j) + a_d * dx
                Vy(j) = Vy(j) + a_d * dy
            Next j
        Next i

        ' Move all the planets.
        For i = 1 To NumPlanets
            Cx(i) = Cx(i) + Vx(i)
            Cy(i) = Cy(i) + Vy(i)
        Next i

        ' Redraw the planets.
        Canvas.Cls
        For i = 1 To NumPlanets
            Canvas.FillColor = Clr(i)
            Canvas.Circle (Cx(i), Cy(i)), R(i), Clr(i)
        Next i
        ' Wait until it's time for the next frame.
        next_time = next_time + mpf
        WaitTill next_time
    Loop
    ' Restore the old FillStyle.
    Canvas.FillStyle = old_style
End Sub
' ************************************************
' Start a new simulation.
' ************************************************
Private Sub CmdRun_Click()
    If Playing Then
        CmdRun.Caption = "Stopped"
        CmdRun.Enabled = False
        Playing = False
    Else
        Playing = True
        CmdRun.Caption = "Stop"
        PlaySimulation
        CmdRun.Caption = "Run"
        CmdRun.Enabled = True
        Playing = False
    End If
End Sub
Private Sub Form_Resize()
Const GAP = 3
Dim hgt As Double
    hgt = ScaleHeight - CmdRun.Height - 2 * GAP
    Canvas.Move 0, 0, ScaleWidth, hgt
    CmdRun.Move (ScaleWidth - CmdRun.Width) / 2, _
        Canvas.Height + GAP
    Label1.Top = CmdRun.Top
    FPSText.Top = CmdRun.Top
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ***********************************************
' Load a new data file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.PLA"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the picture.
    WaitStart
    LoadPlanets fname
    WaitEnd
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    Canvas.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    Canvas.MousePointer = vbDefault
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub