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

Visual Basic Form | 1996-05-02 | 22.5 KB | 729 lines

VERSION 4.00
Begin VB.Form TweenForm
   Caption         =   "Tween"
   ClientHeight    =   4590
   ClientLeft      =   2040
   ClientTop       =   1035
   ClientWidth     =   4635
   Height          =   5280
   Left            =   1980
   LinkTopic       =   "Form1"
   ScaleHeight     =   306
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   309
   Top             =   405
   Width           =   4755
   Begin VB.CommandButton CmdTween
      Caption         =   "Tween"
      Height          =   495
      Left            =   3480
      TabIndex        =   12
      Top             =   480
      Width           =   975
   End
   Begin VB.TextBox TweensText
      Height          =   285
      Left            =   4200
      TabIndex        =   10
      Text            =   "4"
      Top             =   0
      Width           =   375
   End
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   4080
      TabIndex        =   9
      Text            =   "20"
      Top             =   1800
      Width           =   375
   End
   Begin VB.CommandButton CmdPlay
      Caption         =   "Play"
      Default         =   -1  'True
      Height          =   495
      Left            =   3480
      TabIndex        =   7
      Top             =   3480
      Width           =   975
   End
   Begin VB.OptionButton PlayOption
      Caption         =   "Reversing"
      Height          =   255
      Index           =   2
      Left            =   3360
      TabIndex        =   4
      Top             =   3000
      Width           =   1095
   End
   Begin VB.OptionButton PlayOption
      Caption         =   "Looping"
      Height          =   255
      Index           =   1
      Left            =   3360
      TabIndex        =   3
      Top             =   2640
      Width           =   1095
   End
   Begin VB.OptionButton PlayOption
      Caption         =   "Once"
      Height          =   255
      Index           =   0
      Left            =   3360
      TabIndex        =   2
      Top             =   2280
      Value           =   -1  'True
      Width           =   1095
   End
   Begin VB.HScrollBar SBar
      Height          =   255
      Left            =   0
      Max             =   1
      Min             =   1
      TabIndex        =   1
      Top             =   3960
      Value           =   1
      Width           =   3255
   End
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      Height          =   3975
      Left            =   0
      ScaleHeight     =   261
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   213
      TabIndex        =   0
      Top             =   0
      Width           =   3255
   End
   Begin VB.Label Label1
      Caption         =   "Tweens:"
      Height          =   255
      Index           =   2
      Left            =   3360
      TabIndex        =   11
      Top             =   0
      Width           =   615
   End
   Begin VB.Label Label1
      Caption         =   "FPS:"
      Height          =   255
      Index           =   1
      Left            =   3480
      TabIndex        =   8
      Top             =   1800
      Width           =   375
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   2640
      Top             =   4200
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label FrameLabel
      Alignment       =   2  'Center
      BorderStyle     =   1  'Fixed Single
      Caption         =   "1/1"
      Height          =   255
      Left            =   1680
      TabIndex        =   6
      Top             =   4320
      Width           =   735
   End
   Begin VB.Label Label1
      Caption         =   "Frame:"
      Height          =   255
      Index           =   0
      Left            =   1080
      TabIndex        =   5
      Top             =   4320
      Width           =   495
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSave
         Caption         =   "&Save"
         Shortcut        =   ^S
      End
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "Save &As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuFileFrame
      Caption         =   "Frames"
      Begin VB.Menu mnuFrameAfter
         Caption         =   "Insert &After"
      End
      Begin VB.Menu mnuFrameBefore
         Caption         =   "Insert &Before"
      End
      Begin VB.Menu mnuFrameSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFrameDelete
         Caption         =   "&Delete"
         Enabled         =   0   'False
      End
   End
Attribute VB_Name = "TweenForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim NumFrames As Integer
Dim Frames() As New RobotConfig
Dim SelectedFrame As Integer
Dim SelectingFrame As Boolean
Dim FileLoaded As String
Dim DataModified As Boolean
Dim Playing As Boolean
Dim Dragging As Boolean
Dim DragPoint As Integer
Dim DragX As Integer
Dim DragY As Integer
Dim AnchorX As Integer
Dim AnchorY As Integer
' ************************************************
' Convert (X, Y) into the point in the direction
' of (X, Y) that is the correct distance from the
' anchor point. For example, when dragging an
' elbow, the point should be UARM_LEN distance
' from the shoulders.
' ************************************************
Sub AdjustPoint(x As Single, y As Single)
Dim dist As Single
Dim factor As Single
Dim dx As Single
Dim dy As Single
    ' Heads have no anchor point.
    If DragPoint = PART_HEAD Then
        DragX = x
        DragY = y
        Exit Sub
    End If
    dx = x - AnchorX
    dy = y - AnchorY
    dist = Sqr(dx * dx + dy * dy)
    Select Case DragPoint
        Case PART_LELBOW, PART_RELBOW
            factor = UARM_LEN / dist
        Case PART_LHAND, PART_RHAND
            factor = LARM_LEN / dist
        Case PART_LKNEE, PART_RKNEE
            factor = ULEG_LEN / dist
        Case PART_LFOOT, PART_RFOOT
            factor = LLEG_LEN / dist
    End Select
    DragX = AnchorX + dx * factor
    DragY = AnchorY + dy * factor
End Sub
' ************************************************
' Return true if the data has not been modified,
' or the user has saved the changes, or the user
' wants to lose the changes.
' ************************************************
Function DataSafe() As Boolean
Dim ans As Integer
    Do While DataModified
        ans = MsgBox("The data has been modified." & _
            " Do you want to save the changes?", _
            vbYesNoCancel)
        If ans = vbCancel Then Exit Do
        If ans = vbNo Then
            DataSafe = True
            Exit Function
        End If

        ' Otherwise save the data.
        If FileLoaded <> "" Then
            mnuFileSave_Click
        Else
            mnuFileSaveAs_Click
        End If
    Loop
    DataSafe = Not DataModified
End Function
' ************************************************
' Draw the highlight fot the drag.
' ************************************************
Sub DrawDrag()
    If DragPoint = PART_HEAD Then
        Canvas.Line (DragX - NEAR, DragY - NEAR)-Step(NEAR2, NEAR2), , BF
    Else
        Canvas.Line (AnchorX, AnchorY)-(DragX, DragY)
    End If
End Sub
' ************************************************
' Draw the selected configuration.
' ************************************************
Sub DrawSelected()
    Canvas.Cls
    Frames(SelectedFrame).Draw Canvas, True
End Sub
' ************************************************
' Save a robot script into the file.
' ************************************************
Sub SaveScript(fname As String)
Dim fnum As Integer
Dim i As Integer
    On Error GoTo SaveScriptError
    ' Open the file.
    fnum = FreeFile
    Open fname For Output As fnum
    ' Write the number of frames.
    Write #fnum, NumFrames
    ' Write the parameters for each frame.
    For i = 1 To NumFrames
        Frames(i).FileWrite fnum
    Next i
    Close fnum
    FileLoaded = fname
    Caption = "Tween [" & fname & "]"
    DataModified = False
    Exit Sub
SaveScriptError:
    Beep
    MsgBox "Error saving file " & fname & "." & _
        vbCrLf & Format$(Err.Number) & " : " & _
        Err.Description
    Exit Sub
End Sub
' ************************************************
' Load a robot script from the file.
' ************************************************
Sub LoadScript(fname As String)
Dim fnum As Integer
Dim i As Integer
    On Error GoTo SaveScriptError
    ' Open the file.
    fnum = FreeFile
    Open fname For Input As fnum
    ' Read the number of frames.
    Input #fnum, NumFrames
    ReDim Frames(1 To NumFrames)
    SBar.Max = NumFrames
    ' Read the parameters for each frame.
    For i = 1 To NumFrames
        Frames(i).FileInput fnum
    Next i
    Close fnum
    SelectFrame 1
    mnuFrameDelete.Enabled = (NumFrames > 1)
    FileLoaded = fname
    Caption = "Robot [" & fname & "]"
    DataModified = False
    Exit Sub
SaveScriptError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Format$(Err.Number) & " : " & _
        Err.Description
    Exit Sub
End Sub
' ************************************************
' Select and display the indicated frame.
' ************************************************
Sub SelectFrame(index As Integer)
    SelectedFrame = index
    SelectingFrame = True
    SBar.Value = index
    SelectingFrame = False
    FrameLabel.Caption = Format$(index) & "/" & Format$(NumFrames)
    DrawSelected
End Sub
' ************************************************
' Set the point that anchors the selected control
' point. For example, when moving a hand the
' corresponding elbow is the control point.
' ************************************************
Sub SetAnchor()
    Select Case DragPoint
        Case PART_HEAD  ' The head has no anchor.
            AnchorX = -1
        Case PART_LELBOW, PART_RELBOW
            Frames(SelectedFrame).Position _
                PART_SHOULDERS, AnchorX, AnchorY
        Case PART_LHAND
            Frames(SelectedFrame).Position _
                PART_LELBOW, AnchorX, AnchorY
        Case PART_RHAND
            Frames(SelectedFrame).Position _
                PART_RELBOW, AnchorX, AnchorY
        Case PART_LKNEE, PART_RKNEE
            Frames(SelectedFrame).Position _
                PART_HIPS, AnchorX, AnchorY
        Case PART_LFOOT
            Frames(SelectedFrame).Position _
                PART_LKNEE, AnchorX, AnchorY
        Case PART_RFOOT
            Frames(SelectedFrame).Position _
                PART_RKNEE, AnchorX, AnchorY
    End Select
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
' ************************************************
' Grab the nearest control point within distance
' NEAR of the mouse.
' ************************************************
Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Integer
Dim best_i As Integer
Dim best_dist As Long
Dim dx As Long
Dim dy As Long
Dim dist As Long
Dim fx As Integer
Dim fy As Integer
    ' Find the closest control point.
    best_dist = NEAR + 1
    For i = MIN_PART To MAX_CONTROL_PART
        Frames(SelectedFrame).Position i, fx, fy
        dx = x - fx
        dy = y - fy
        dist = Sqr(dx * dx + dy * dy)
        If best_dist > dist Then
            best_dist = dist
            best_i = i
        End If
    Next i
    ' If nothing is close enough, leave.
    If best_dist > NEAR Then
        Beep
        Exit Sub
    End If
    ' Begin moving the control point.
    Dragging = True
    DragPoint = best_i
    Canvas.DrawMode = vbInvert
    SetAnchor
    DragX = x
    DragY = y
    DrawDrag
End Sub
' ************************************************
' Continue dragging a control point.
' ************************************************
Private Sub Canvas_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not Dragging Then Exit Sub
    ' Erase the old highlight.
    DrawDrag
    ' Draw the new highlight.
    AdjustPoint x, y
    DrawDrag
End Sub
' ************************************************
' Finish dragging the control point.
' ************************************************
Private Sub Canvas_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not Dragging Then Exit Sub
    Dragging = False
    ' Erase the old highlight.
    DrawDrag
    Canvas.DrawMode = vbCopyPen
    ' Adjust the control point.
    AdjustPoint x, y
    Frames(SelectedFrame).MoveControlPoint _
        DragPoint, AnchorX, AnchorY, DragX, DragY
    DataModified = True
    DrawSelected
End Sub
' ************************************************
' Play the animation.
' ************************************************
Private Sub CmdPlay_Click()
    If Playing Then
        Playing = False
        CmdPlay.Caption = "Stopped"
        CmdPlay.Enabled = False
    Else
        Playing = True
        CmdPlay.Caption = "Stop"
        PlayData
        CmdPlay.Caption = "Play"
        Playing = False
        CmdPlay.Enabled = True
        DrawSelected
    End If
End Sub
' ************************************************
' Play the animation.
' ************************************************
Sub PlayData()
Dim mpf As Long     ' Milliseconds per frame.
Dim frame As Integer
Dim next_time As Long
Dim play_type As Integer
Dim num As Integer
Dim start_time As Single
Dim stop_time As Single
    ' See how fast we should go.
    If Not IsNumeric(FPSText.Text) Then _
        FPSText.Text = "10"
    mpf = 1000 \ CLng(FPSText.Text)
    ' See what kind of animation this should be.
    For play_type = 0 To 2
        If PlayOption(play_type).Value Then Exit For
    Next play_type
    If play_type > 2 Then play_type = 0
    ' Start the animation.
    start_time = Timer
    next_time = GetTickCount()
    Do While Playing
        ' Show the frames.
        For frame = 1 To NumFrames
            If Not Playing Then Exit Do
            num = num + 1

            ' Draw the frame.
            Canvas.Cls
            Frames(frame).Draw Canvas, False

            ' Wait until it's time for the next frame.
            next_time = next_time + mpf
            WaitTill next_time
        Next frame
        ' If this is a one time deal, stop now.
        If play_type = 0 Then Exit Do

        ' If this is a reversing run, go backwards.
        If play_type = 2 Then
            For frame = NumFrames - 1 To 2 Step -1
                If Not Playing Then Exit Do
                num = num + 1

                ' Draw the frame.
                Canvas.Cls
                Frames(frame).Draw Canvas, False

                ' Wait until it's time for the next frame.
                next_time = next_time + mpf
                WaitTill next_time
            Next frame
        End If
    Loop
    stop_time = Timer
    MsgBox "Displayed" & Str$(num) & _
        " frames in " & _
        Format$(stop_time - start_time, "0.00") & _
        " seconds (" & _
        Format$(num / (stop_time - start_time), "0.00") & _
        " FPS)."
End Sub
' ************************************************
' Make the tweens.
' ************************************************
Private Sub CmdTween_Click()
Dim num_tweens As Integer
Dim num_frames As Integer
Dim frame1 As Integer
Dim frame2 As Integer
Dim frac1 As Single
Dim i As Integer
Dim frame As Integer
    ' See how many tweens to make.
    If Not IsNumeric(TweensText.Text) Then _
        TweensText.Text = "4"
    num_tweens = TweensText.Text
    If num_tweens < 1 Then num_tweens = 1
    ' Make room for the new frames.
    num_frames = num_tweens * (NumFrames - 1) + NumFrames
    ReDim Preserve Frames(1 To num_frames)
    ' Spread the original frames out.
    For frame = NumFrames To 2 Step -1
        frame1 = num_tweens * (frame - 1) + frame
        Frames(frame1).CopyFrame Frames(frame)
    Next frame
    ' Make the tweens.
    For frame = 1 To NumFrames - 1
        frame1 = num_tweens * (frame - 1) + frame
        frame2 = frame1 + num_tweens + 1
        For i = frame1 + 1 To frame2 - 1
            frac1 = (frame2 - i) / (frame2 - frame1)
            Frames(i).Tween frac1, _
                Frames(frame1), Frames(frame2)
        Next i
    Next frame
    NumFrames = num_frames
    SBar.Max = NumFrames
    SelectFrame num_tweens * (SelectedFrame - 1) + _
        SelectedFrame
    DataModified = True
End Sub
Private Sub Form_Load()
    ' Create a single default frame.
    NumFrames = 1
    ReDim Frames(1 To NumFrames)
    With Frames(1)
        .SetParameters _
            Canvas.ScaleWidth / 2, _
            (Canvas.ScaleHeight - .MaxHeight) / 2 + _
                .HeadRoom, _
            210, -30, 150, 30, 240, -60, 255, -75
    End With
    ' Position the scroll bar.
    SBar.Top = Canvas.Top + Canvas.Height + 1
    SelectFrame 1
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Cancel = Not DataSafe()
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ************************************************
' Load a robot script file.
' ************************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    If Not DataSafe() Then Exit Sub
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.FilterIndex = 1
    FileDialog.filename = "*.ROB"
    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 robot script file.
    WaitStart
    LoadScript fname
    WaitEnd
End Sub
' ************************************************
' Save the robot script file.
' ************************************************
Private Sub mnuFileSave_Click()
    If FileLoaded = "" Then
        mnuFileSaveAs_Click
        Exit Sub
    End If
    WaitStart
    SaveScript FileLoaded
    WaitEnd
End Sub
' ************************************************
' Save the robot script file with a new name.
' ************************************************
Private Sub mnuFileSaveAs_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.FilterIndex = 1
    FileDialog.filename = "*.ROB"
    FileDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    FileDialog.ShowSave
    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)
    ' Save the robot script file.
    WaitStart
    SaveScript fname
    WaitEnd
End Sub
' ************************************************
' Insert a frame next to the selected one.
' ************************************************
Private Sub AddFrame()
Dim i As Integer
    NumFrames = NumFrames + 1
    ReDim Preserve Frames(1 To NumFrames)
    For i = NumFrames - 1 To SelectedFrame Step -1
        Frames(i + 1).CopyFrame Frames(i)
    Next i
    SBar.Max = NumFrames
    mnuFrameDelete.Enabled = (NumFrames > 1)
    DataModified = True
End Sub
' ************************************************
' Insert a frame after the selected one.
' ************************************************
Private Sub mnuFrameAfter_Click()
    AddFrame
    SelectFrame SelectedFrame + 1
End Sub
' ************************************************
' Insert a frame before the selected one.
' ************************************************
Private Sub mnuFrameBefore_Click()
    AddFrame
    FrameLabel.Caption = Format$(SelectedFrame) & "/" & Format$(NumFrames)
End Sub
' ************************************************
' Delete the selected frame.
' ************************************************
Private Sub mnuFrameDelete_Click()
Dim i As Integer
    For i = SelectedFrame To NumFrames - 1
        Frames(i).CopyFrame Frames(i + 1)
    Next i
    NumFrames = NumFrames - 1
    ReDim Preserve Frames(1 To NumFrames)
    SBar.Max = NumFrames
    If SelectedFrame > NumFrames Then _
       SelectedFrame = NumFrames
    SelectFrame SelectedFrame
    mnuFrameDelete.Enabled = (NumFrames > 1)
    DataModified = True
End Sub
' ************************************************
' Select a new frame.
' ************************************************
Private Sub SBar_Change()
    If SelectingFrame Then Exit Sub
    SelectFrame SBar.Value
End Sub
' ************************************************
' Select a new frame.
' ************************************************
Private Sub SBar_Scroll()
    SBar_Change
End Sub