Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH14/SRC/ANIMATED.FRM

Visual Basic Form | 1996-05-02 | 10.5 KB | 348 lines

VERSION 4.00
Begin VB.Form AnimatedForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Animated"
   ClientHeight    =   5310
   ClientLeft      =   1380
   ClientTop       =   1035
   ClientWidth     =   6870
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6000
   KeyPreview      =   -1  'True
   Left            =   1320
   LinkTopic       =   "Form1"
   ScaleHeight     =   5310
   ScaleWidth      =   6870
   Top             =   405
   Width           =   6990
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   6480
      TabIndex        =   15
      Text            =   "10"
      Top             =   3600
      Width           =   375
   End
   Begin VB.CommandButton CmdGo
      Caption         =   "Go"
      Default         =   -1  'True
      Height          =   495
      Left            =   5640
      TabIndex        =   14
      Top             =   4080
      Width           =   975
   End
   Begin VB.TextBox DText
      Height          =   285
      Left            =   6000
      TabIndex        =   10
      Text            =   "3"
      Top             =   1560
      Width           =   735
   End
   Begin VB.Frame Frame1
      Caption         =   "Post-Rotations"
      Height          =   1335
      Index           =   1
      Left            =   5400
      TabIndex        =   2
      Top             =   2040
      Width           =   1455
      Begin VB.TextBox ZW2Text
         Height          =   285
         Left            =   600
         MaxLength       =   6
         TabIndex        =   5
         Text            =   "0.0"
         Top             =   960
         Width           =   735
      End
      Begin VB.TextBox YW2Text
         Height          =   285
         Left            =   600
         MaxLength       =   6
         TabIndex        =   4
         Text            =   "0.1"
         Top             =   600
         Width           =   735
      End
      Begin VB.TextBox XW2Text
         Height          =   285
         Left            =   600
         MaxLength       =   6
         TabIndex        =   3
         Text            =   "0.2"
         Top             =   240
         Width           =   735
      End
      Begin VB.Label Label1
         Caption         =   "Z"
         Height          =   255
         Index           =   11
         Left            =   240
         TabIndex        =   8
         Top             =   960
         Width           =   255
      End
      Begin VB.Label Label1
         Caption         =   "Y"
         Height          =   255
         Index           =   10
         Left            =   240
         TabIndex        =   7
         Top             =   600
         Width           =   255
      End
      Begin VB.Label Label1
         Caption         =   "X"
         Height          =   255
         Index           =   9
         Left            =   240
         TabIndex        =   6
         Top             =   240
         Width           =   255
      End
   End
   Begin VB.Frame Frame1
      Caption         =   "Pre-Rotations"
      Height          =   1335
      Index           =   0
      Left            =   5400
      TabIndex        =   1
      Top             =   0
      Width           =   1455
      Begin VB.CheckBox YZCheck
         Caption         =   "YZ Plane"
         Height          =   255
         Left            =   120
         TabIndex        =   13
         Top             =   960
         Width           =   1215
      End
      Begin VB.CheckBox XZCheck
         Caption         =   "XZ Plane"
         Height          =   255
         Left            =   120
         TabIndex        =   12
         Top             =   600
         Width           =   1215
      End
      Begin VB.CheckBox XYCheck
         Caption         =   "XY Plane"
         Height          =   255
         Left            =   120
         TabIndex        =   11
         Top             =   240
         Width           =   1215
      End
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   5295
      Left            =   0
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   349
      TabIndex        =   0
      Top             =   0
      Width           =   5295
   End
   Begin VB.Label Label1
      Caption         =   "Frames/Sec"
      Height          =   255
      Index           =   0
      Left            =   5400
      TabIndex        =   16
      Top             =   3600
      Width           =   1095
   End
   Begin VB.Label Label1
      Caption         =   "D"
      Height          =   255
      Index           =   12
      Left            =   5640
      TabIndex        =   9
      Top             =   1560
      Width           =   255
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "AnimatedForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#
Dim Projector(1 To 5, 1 To 5) As Single
Dim ThePicture As ObjPicture
Dim Running As Boolean
' ************************************************
' Animate the picture.
' ************************************************
Private Sub Animate()
Const Dtheta = PI / 40
Dim xy_rot As Single
Dim xz_rot As Single
Dim yz_rot As Single
Dim xw2_rot As Single
Dim yw2_rot As Single
Dim zw2_rot As Single
Dim XY(1 To 5, 1 To 5) As Single
Dim XZ(1 To 5, 1 To 5) As Single
Dim YZ(1 To 5, 1 To 5) As Single
Dim XW2(1 To 5, 1 To 5) As Single
Dim YW2(1 To 5, 1 To 5) As Single
Dim ZW2(1 To 5, 1 To 5) As Single
Dim S(1 To 5, 1 To 5) As Single
Dim T(1 To 5, 1 To 5) As Single
Dim P(1 To 5, 1 To 5) As Single
Dim M12(1 To 5, 1 To 5) As Single
Dim M34(1 To 5, 1 To 5) As Single
Dim M1_4(1 To 5, 1 To 5) As Single
Dim M56(1 To 5, 1 To 5) As Single
Dim M1_6(1 To 5, 1 To 5) As Single
Dim M_All(1 To 5, 1 To 5) As Single
Dim D As Single
Dim AnimateXY As Boolean
Dim AnimateXZ As Boolean
Dim AnimateYZ As Boolean
Dim next_time As Long
Dim ms_per_frame As Long
    If Not IsNumeric(XW2Text.Text) Then Exit Sub
    If Not IsNumeric(YW2Text.Text) Then Exit Sub
    If Not IsNumeric(ZW2Text.Text) Then Exit Sub
    If Not IsNumeric(DText.Text) Then Exit Sub
    If Not IsNumeric(FPSText) Then Exit Sub
    xw2_rot = CSng(XW2Text.Text)
    yw2_rot = CSng(YW2Text.Text)
    zw2_rot = CSng(ZW2Text.Text)
    D = CSng(DText.Text)
    ms_per_frame = 1000 / CLng(FPSText)
    MousePointer = vbHourglass
    Refresh
    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next
    ' Calculate the matrices that don't change.
    m4XWRotate XW2, xw2_rot
    m4YWRotate YW2, yw2_rot
    m4ZWRotate ZW2, zw2_rot
    ' Calculate the projection matrix.
    m4PerspectiveW P, D
    ' Scale and translate so it looks OK in pixels.
    m4Scale S, 75, -75, 1, 1
    m4Translate T, Pict.ScaleWidth / 2, Pict.ScaleHeight / 2, 0, 0
    m4MatMultiplyFull M12, P, XW2
    m4MatMultiply M34, YW2, ZW2
    m4MatMultiplyFull M1_4, M12, M34
    m4MatMultiply M56, S, T
    m4MatMultiplyFull M1_6, M1_4, M56
    ' See which rotations we are animating.
    AnimateXY = (XYCheck.value = vbChecked)
    AnimateXZ = (XZCheck.value = vbChecked)
    AnimateYZ = (YZCheck.value = vbChecked)
    ' Start the animation.
    Do While Running
        next_time = GetTickCount + ms_per_frame

        ' Calculate the changing transformations.
        m4XYRotate XY, xy_rot
        m4XZRotate XZ, xz_rot
        m4YZRotate YZ, yz_rot
        m4MatMultiply M12, XY, XZ
        m4MatMultiply M1_4, M12, YZ
        m4MatMultiplyFull M_All, M1_4, M1_6
        If AnimateXY Then xy_rot = xy_rot + Dtheta
        If AnimateXZ Then xz_rot = xz_rot + Dtheta
        If AnimateYZ Then yz_rot = yz_rot + Dtheta
        ' Transform the points.
        ThePicture.ApplyFull M_All
        ' Display the data.
        Pict.Cls
        ThePicture.Draw Pict
        DoEvents
        WaitTill next_time
    Loop
    MousePointer = vbDefault
End Sub
Private Sub CmdGo_Click()
    If Running Then
        CmdGo.Caption = "Stopped"
        CmdGo.Enabled = False
        Running = False
    Else
        CmdGo.Caption = "Stop"
        Running = True
        Animate
        CmdGo.Enabled = True
        CmdGo.Caption = "Go"
        Running = False
    End If
End Sub
Private Sub Form_Load()
    ' Create the data.
    CreateData
End Sub
' ************************************************
' Create the surface.
' ************************************************
Sub CreateData()
Dim pline As ObjPolyline4D
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim w As Integer
    MousePointer = vbHourglass
    Refresh
    Set ThePicture = New ObjPicture
    Set pline = New ObjPolyline4D
    ThePicture.objects.Add pline
    For x = -1 To 1 Step 2
        For y = -1 To 1 Step 2
            For z = -1 To 1 Step 2
                For w = -1 To 1 Step 2
                    If x = -1 Then _
                        pline.AddSegment _
                            x, y, z, w, _
                            1, y, z, w
                    If y = -1 Then _
                        pline.AddSegment _
                            x, y, z, w, _
                            x, 1, z, w
                    If z = -1 Then _
                        pline.AddSegment _
                            x, y, z, w, _
                            x, y, 1, w
                    If w = -1 Then _
                        pline.AddSegment _
                            x, y, z, w, _
                            x, y, z, 1
                Next w
            Next z
        Next y
    Next x
    MousePointer = vbDefault
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub