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

Visual Basic Form | 1997-01-08 | 9.4 KB | 325 lines

VERSION 4.00
Begin VB.Form SpriteForm
   Caption         =   "Sprites"
   ClientHeight    =   5235
   ClientLeft      =   1320
   ClientTop       =   1110
   ClientWidth     =   6870
   Height          =   5925
   Left            =   1260
   LinkTopic       =   "Form1"
   ScaleHeight     =   349
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   458
   Top             =   480
   Width           =   6990
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   1440
      TabIndex        =   4
      Text            =   "20"
      Top             =   4920
      Width           =   375
   End
   Begin VB.TextBox ObjText
      Height          =   285
      Left            =   1440
      TabIndex        =   3
      Text            =   "20"
      Top             =   4560
      Width           =   375
   End
   Begin VB.CommandButton CmdStart
      Caption         =   "Start"
      Default         =   -1  'True
      Height          =   495
      Left            =   2160
      TabIndex        =   1
      Top             =   4620
      Width           =   855
   End
   Begin VB.PictureBox Court
      AutoRedraw      =   -1  'True
      Height          =   4455
      Left            =   0
      ScaleHeight     =   293
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   453
      TabIndex        =   0
      Top             =   0
      Width           =   6855
   End
   Begin VB.Label Label1
      Caption         =   "Frames per second:"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   5
      Top             =   4920
      Width           =   1455
   End
   Begin VB.Label Label1
      Caption         =   "Number of objects:"
      Height          =   255
      Index           =   1
      Left            =   0
      TabIndex        =   2
      Top             =   4560
      Width           =   1455
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "SpriteForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim xmax As Integer
Dim ymax As Integer
Dim Sprites As Collection
Dim Playing As Boolean
' ************************************************
' Generate some random data.
' ************************************************
Sub InitData()
Dim obj As Object
Dim num_obj As Integer
Dim i As Integer
    ' See how many objects there should be.
    If Not IsNumeric(ObjText.Text) Then Exit Sub
    num_obj = CInt(ObjText.Text)
    If num_obj < 1 Then Exit Sub
    ' Create the sprites.
    Set Sprites = New Collection
    For i = 1 To num_obj
        ' Pick a random sprite type.
        Select Case Int(3 * Rnd)
            Case 0
                Set obj = InitRectangle()
            Case 1
                Set obj = InitTriangle()
            Case 2
                Set obj = InitCircle()
        End Select
        ' Add the sprite to the list.
        Sprites.Add obj
    Next i
End Sub
' ************************************************
' Create and initialize a random CircleSprite.
' ************************************************
Function InitCircle() As CircleSprite
Dim obj As Object
Dim radius As Integer
Dim x As Integer
Dim y As Integer
Dim dx As Integer
Dim dy As Integer
Dim c As Integer
Dim color As Long

    radius = Int(15 * Rnd + 5)
    x = Int((xmax - radius + 1) * Rnd + radius / 2)
    y = Int((ymax - radius + 1) * Rnd + radius / 2)
    dx = Int(11 * Rnd - 5)
    dy = Int(11 * Rnd - 5)
    c = Int(15 * Rnd)
    If c >= 7 Then c = c + 1
    color = QBColor(c)
    Set obj = New CircleSprite
    obj.InitializeSprite radius, x, y, dx, dy, color
    Set InitCircle = obj
End Function
' ************************************************
' Create and initialize a random TriangleSprite.
' ************************************************
Function InitTriangle() As TriangleSprite
Const PI = 3.14159
Const PI_OVER_3 = PI / 3
Const PI_OVER_8 = PI / 8
Const PI_OVER_16 = PI / 16
Dim obj As Object
Dim x As Integer
Dim y As Integer
Dim r1 As Integer
Dim t1 As Integer
Dim r2 As Integer
Dim t2 As Integer
Dim r3 As Integer
Dim t3 As Integer
Dim t As Single
Dim dx As Integer
Dim dy As Integer
Dim dt As Single
Dim c As Integer
Dim color As Long

    x = Int((xmax - 20) * Rnd + 10)
    y = Int((ymax - 20) * Rnd + 10)
    r1 = Int(15 * Rnd + 10)
    t1 = PI_OVER_3 * Rnd
    r2 = Int(15 * Rnd + 10)
    t2 = PI_OVER_3 * Rnd + 2 * PI_OVER_3
    r3 = Int(15 * Rnd + 10)
    t3 = PI_OVER_3 * Rnd + 4 * PI_OVER_3
    dx = Int(11 * Rnd - 5)
    dy = Int(11 * Rnd - 5)
    dt = PI_OVER_8 * Rnd - PI_OVER_16
    c = Int(15 * Rnd)
    If c >= 7 Then c = c + 1
    color = QBColor(c)
    Set obj = New TriangleSprite
    obj.InitializeSprite _
        x, y, dx, dy, r1, t1, r2, t2, r3, t3, _
        dt, color
    Set InitTriangle = obj
End Function
' ************************************************
' Create and initialize a random RectangleSprite.
' ************************************************
Function InitRectangle() As RectangleSprite
Const PI = 3.14159
Const PI_OVER_2 = PI / 2
Const PI_OVER_8 = PI / 8
Const PI_OVER_16 = PI / 16
Dim obj As Object
Dim w As Integer
Dim h As Integer
Dim x As Integer
Dim y As Integer
Dim t As Single
Dim dx As Integer
Dim dy As Integer
Dim dt As Single
Dim c As Integer
Dim color As Long

    w = Int(20 * Rnd + 10)
    h = Int(20 * Rnd + 10)
    x = Int((xmax - w + 1) * Rnd + w / 2)
    y = Int((ymax - h + 1) * Rnd + h / 2)
    dx = Int(11 * Rnd - 5)
    dy = Int(11 * Rnd - 5)
    t = PI_OVER_2 * Rnd
    dt = PI_OVER_8 * Rnd - PI_OVER_16
    c = Int(15 * Rnd)
    If c >= 7 Then c = c + 1
    color = QBColor(c)
    Set obj = New RectangleSprite
    obj.InitializeSprite _
        w, h, x, y, t, dx, dy, dt, color
    Set InitRectangle = obj
End Function
' ************************************************
' Start the animation.
' ************************************************
Private Sub CmdStart_Click()
    If Playing Then
        Playing = False
        CmdStart.Caption = "Stopped"
        CmdStart.Enabled = False
    Else
        CmdStart.Caption = "Stop"
        Playing = True
        InitData
        PlayData
        Playing = False
        CmdStart.Caption = "Start"
        CmdStart.Enabled = True
    End If
End Sub
' ************************************************
' Play the animation.
' ************************************************
Sub PlayData()
Dim mpf As Long     ' Milliseconds per frame.
Dim next_time As Long
Dim old_style As Integer
Dim obj As Object
Dim frames As Integer
Dim start_time As Single
Dim stop_time As Single
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim Wid As Long
Dim Hgt As Long
Dim num_bits As Long
Dim bytes() As Byte
    ' Set FillStyle to vbSolid.
    old_style = Court.FillStyle
    Court.FillStyle = vbSolid
    ' See how fast we should go.
    If Not IsNumeric(FPSText.Text) Then _
        FPSText.Text = "10"
    mpf = 1000 \ CLng(FPSText.Text)
    ' Create a blank background.
    Court.Line (0, 0)- _
        Step(Court.ScaleWidth, Court.ScaleHeight), _
        Court.BackColor, BF
    ' Get the background image pixels.
    hbm = Court.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    Wid = bm.bmWidthBytes
    Hgt = bm.bmHeight
    num_bits = Wid * Hgt
    ReDim bytes(1 To Wid, 1 To Hgt)
    status = GetBitmapBits(hbm, num_bits, bytes(1, 1))
    ' Start the animation.
    next_time = GetTickCount()
    start_time = Timer
    Do While Playing
        frames = frames + 1

        ' Move each sprite.
        For Each obj In Sprites
            obj.MoveSprite xmax, ymax
        Next obj

        ' Wait until it's time for the next frame.
        next_time = next_time + mpf
        WaitTill next_time

        ' Erase using SetBitmapBits.
        status = SetBitmapBits(hbm, num_bits, bytes(1, 1))

        ' Draw the sprites.
        For Each obj In Sprites
            obj.DrawSprite Court
        Next obj
        Court.Refresh
    Loop
    stop_time = Timer
    MsgBox "Displayed" & Str$(frames) & _
        " frames in " & _
        Format$(stop_time - start_time, "0.00") & _
        " seconds (" & _
        Format$(frames / (stop_time - start_time), "0.00") & _
        " FPS)."
    ' Restore the old FillStyle.
    Court.FillStyle = old_style
End Sub
' ************************************************
' Make the ball court nice and big.
' ************************************************
Private Sub Form_Resize()
Const GAP = 3
    FPSText.Top = ScaleHeight - GAP - FPSText.Height
    Label1(0).Top = FPSText.Top
    ObjText.Top = FPSText.Top - GAP - ObjText.Height
    Label1(1).Top = ObjText.Top
    CmdStart.Top = (ObjText.Top + FPSText.Top + FPSText.Height - CmdStart.Height) / 2
    Court.Move 0, 0, ScaleWidth, ObjText.Top - GAP
    xmax = Court.ScaleWidth - 1
    ymax = Court.ScaleHeight - 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub