Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH10/SRC/BEZIER.FRM

Visual Basic Form | 1996-05-02 | 20.8 KB | 693 lines

VERSION 4.00
Begin VB.Form BezierForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Bezier"
   ClientHeight    =   5700
   ClientLeft      =   300
   ClientTop       =   840
   ClientWidth     =   9105
   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          =   6390
   KeyPreview      =   -1  'True
   Left            =   240
   LinkTopic       =   "Form1"
   ScaleHeight     =   5700
   ScaleWidth      =   9105
   Top             =   210
   Width           =   9225
   Begin VB.OptionButton Choice
      Caption         =   "Urn"
      Height          =   255
      Index           =   8
      Left            =   7080
      TabIndex        =   18
      Top             =   2880
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Tent"
      Height          =   255
      Index           =   2
      Left            =   7080
      TabIndex        =   17
      Top             =   720
      Width           =   2055
   End
   Begin VB.CheckBox ShowGridCheck
      Caption         =   "Show Control Grid"
      Height          =   255
      Left            =   7080
      TabIndex        =   16
      Top             =   3840
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Hill"
      Height          =   255
      Index           =   0
      Left            =   7080
      TabIndex        =   15
      Top             =   0
      Value           =   -1  'True
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Wave"
      Height          =   255
      Index           =   1
      Left            =   7080
      TabIndex        =   14
      Top             =   360
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Curl"
      Height          =   255
      Index           =   3
      Left            =   7080
      TabIndex        =   13
      Top             =   1080
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Pipe"
      Height          =   255
      Index           =   4
      Left            =   7080
      TabIndex        =   12
      Top             =   1440
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Cowling"
      Height          =   255
      Index           =   5
      Left            =   7080
      TabIndex        =   11
      Top             =   1800
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Twist"
      Height          =   255
      Index           =   6
      Left            =   7080
      TabIndex        =   10
      Top             =   2160
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Spiral"
      Height          =   255
      Index           =   7
      Left            =   7080
      TabIndex        =   9
      Top             =   2520
      Width           =   2055
   End
   Begin VB.CheckBox ShowControlsCheck
      Caption         =   "Show Control Points"
      Height          =   255
      Left            =   7080
      TabIndex        =   8
      Top             =   3480
      Width           =   2055
   End
   Begin VB.CheckBox ShowAxesCheck
      Caption         =   "Show Axes"
      Height          =   255
      Left            =   7080
      TabIndex        =   7
      Top             =   4200
      Width           =   2055
   End
   Begin VB.TextBox PhiText
      Height          =   285
      Left            =   3600
      TabIndex        =   6
      Text            =   "0.1570"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox ThetaText
      Height          =   285
      Left            =   2040
      TabIndex        =   4
      Text            =   "0.6283"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox RText
      Height          =   285
      Left            =   480
      TabIndex        =   2
      Text            =   "10"
      Top             =   5400
      Width           =   855
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   5295
      Left            =   0
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   461
      TabIndex        =   0
      Top             =   0
      Width           =   6975
   End
   Begin MSComDlg.CommonDialog LoadDialog
      Left            =   7080
      Top             =   4800
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "Phi"
      Height          =   255
      Index           =   2
      Left            =   3240
      TabIndex        =   5
      Top             =   5400
      Width           =   375
   End
   Begin VB.Label Label1
      Caption         =   "Theta"
      Height          =   255
      Index           =   1
      Left            =   1440
      TabIndex        =   3
      Top             =   5400
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "R"
      Height          =   255
      Index           =   0
      Left            =   240
      TabIndex        =   1
      Top             =   5400
      Width           =   255
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      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
Attribute VB_Name = "BezierForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Location of viewing eye.
Dim EyeR As Single
Dim EyeTheta As Single
Dim EyePhi As Single
Const Dtheta = PI / 20
Const Dphi = PI / 20
Const Dr = 1
' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#
Dim Projector(1 To 4, 1 To 4) As Single
Dim ThePicture As ObjPicture
Dim TheSurface As ObjBezier
Dim ShowingParameters As Boolean
Dim ChoiceNum As Integer
' *******************************************************
' Rotate the points in the cube and draw the cube.
' *******************************************************
Private Sub DrawData(pic As Object)
Dim s(1 To 4, 1 To 4) As Single
Dim t(1 To 4, 1 To 4) As Single
Dim ST(1 To 4, 1 To 4) As Single
Dim PST(1 To 4, 1 To 4) As Single
    MousePointer = vbHourglass
    Refresh
    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next
    ' Scale and translate so it looks OK in pixels.
    m3Scale s, 35, -35, 1
    m3Translate t, 230, 175, 0
    m3MatMultiplyFull ST, s, t
    m3MatMultiplyFull PST, Projector, ST
    ' Transform the points.
    ThePicture.ApplyFull PST
    ' Display the data.
    pic.Cls
    ThePicture.Draw pic, EyeR
    pic.Refresh
    ' Display the viewnig parameters.
    ShowViewingParameters
    MousePointer = vbDefault
End Sub
' ************************************************
' Set the control points for a urn.
' ************************************************
Sub MakeUrn()
Dim r(1 To 5) As Single
Dim h(1 To 5) As Single
Dim i As Integer
    TheSurface.SetBounds 5, 6
    r(1) = 1
    r(2) = 1
    r(3) = 5
    r(4) = 1.5
    r(5) = 1.5
    h(1) = 4
    h(2) = 3.5
    h(3) = 2
    h(4) = -1
    h(5) = -3

    For i = 1 To 5
        TheSurface.SetControlPoint i, 1, -r(i), h(i), 0
        TheSurface.SetControlPoint i, 2, -r(i), h(i), -1.5 * r(i)
        TheSurface.SetControlPoint i, 3, 2 * r(i), h(i), -1.5 * r(i)
        TheSurface.SetControlPoint i, 4, 2 * r(i), h(i), 1.5 * r(i)
        TheSurface.SetControlPoint i, 5, -r(i), h(i), 1.5 * r(i)
        TheSurface.SetControlPoint i, 6, -r(i), h(i), 0
    Next i
End Sub
' ************************************************
' Set the control points for a pipe.
' ************************************************
Sub MakePipe()
Const s = 3
Dim i As Integer
Dim x As Single
    TheSurface.SetBounds 4, 6
    For i = 1 To 4
        x = 1.5 * (i - 2.5)
        TheSurface.SetControlPoint i, 1, x, _
            -s, 0
        TheSurface.SetControlPoint i, 2, x, _
            -s, -s
        TheSurface.SetControlPoint i, 3, x, _
            s, -s
        TheSurface.SetControlPoint i, 4, x, _
            s, s
        TheSurface.SetControlPoint i, 5, x, _
            -s, s
        TheSurface.SetControlPoint i, 6, x, _
            -s, 0
    Next i
End Sub
' ************************************************
' Set the control points for a curl.
' ************************************************
Sub MakeCurl()
Dim ang As Integer
Dim j As Integer
Dim r As Single
Dim x As Single
Dim y As Single
Dim z As Single
    TheSurface.SetBounds 4, 4
    For j = 1 To 4
        z = 1.5 * (j - 2.5)
        r = 6 - Abs(2 * j - 5)
        For ang = 1 To 4
            x = r * Cos((ang - 1) * PI / 2)
            y = r * Sin((ang - 1) * PI / 2)
            TheSurface.SetControlPoint ang, j, x, y, z
        Next ang
    Next j
End Sub
' ************************************************
' Set the control points for a wave.
' ************************************************
Sub MakeWave()
Dim i As Integer
Dim j As Integer

    TheSurface.SetBounds 4, 4
    ' Start flat and modify from there.
    For i = 1 To 4
        For j = 1 To 4
            TheSurface.SetControlPoint i, j, 2 * i - 5, 0, 2 * j - 5
        Next j
    Next i
    ' Make the modifications.
    TheSurface.SetControlPoint 2, 2, -1, -10, -1
    TheSurface.SetControlPoint 2, 3, -1, 10, 1
    TheSurface.SetControlPoint 3, 2, 1, -10, -1
    TheSurface.SetControlPoint 3, 3, 1, 10, 1
End Sub
' ************************************************
' Set the control points for a tent.
' ************************************************
Sub MakeTent()
    TheSurface.SetBounds 3, 3
    TheSurface.SetControlPoint 1, 1, -3, -2, -3
    TheSurface.SetControlPoint 1, 2, -3, 2, 0
    TheSurface.SetControlPoint 1, 3, -3, -2, 3
    TheSurface.SetControlPoint 2, 1, 0, 2, -3
    TheSurface.SetControlPoint 2, 2, 0, 4, 0
    TheSurface.SetControlPoint 2, 3, 0, 2, 3
    TheSurface.SetControlPoint 3, 1, 3, -2, -3
    TheSurface.SetControlPoint 3, 2, 3, 2, 0
    TheSurface.SetControlPoint 3, 3, 3, -2, 3
End Sub
' ************************************************
' Set the control points for a spiral.
' ************************************************
Sub MakeSpiral()
    TheSurface.SetBounds 5, 2
    TheSurface.SetControlPoint 1, 1, -4, 2, 0
    TheSurface.SetControlPoint 1, 2, -4, -2, 0
    TheSurface.SetControlPoint 2, 1, -2, 0, -4
    TheSurface.SetControlPoint 2, 2, -2, 0, 4
    TheSurface.SetControlPoint 3, 1, 0, -6, 0
    TheSurface.SetControlPoint 3, 2, 0, 6, 0
    TheSurface.SetControlPoint 4, 1, 2, 0, 4
    TheSurface.SetControlPoint 4, 2, 2, 0, -4
    TheSurface.SetControlPoint 5, 1, 4, 2, 0
    TheSurface.SetControlPoint 5, 2, 4, -2, 0
End Sub
' ************************************************
' Set the control points for a twist.
' ************************************************
Sub MakeTwist()
    TheSurface.SetBounds 2, 2
    TheSurface.SetControlPoint 1, 1, -2, 3, 3
    TheSurface.SetControlPoint 1, 2, -3, 3, -3
    TheSurface.SetControlPoint 2, 1, 3, 4, -2
    TheSurface.SetControlPoint 2, 2, 2, -3, 0
End Sub
' ************************************************
' Set the control points for a cowling.
' ************************************************
Sub MakeCowl()
Dim i As Integer
Dim s As Single
Dim y As Single
    TheSurface.SetBounds 4, 6
    For i = 1 To 4
        y = 3 - 2 * Abs(i - 2.5)

        s = 2 + i / 2

        TheSurface.SetControlPoint i, 1, _
            1.25 * s - 1, y, 0
        TheSurface.SetControlPoint i, 2, _
            1.25 * s - 1, y, s
        TheSurface.SetControlPoint i, 3, _
            -s - 1, y, s
        TheSurface.SetControlPoint i, 4, _
            -s - 1, y, -s
        TheSurface.SetControlPoint i, 5, _
            1.25 * s - 1, y, -s
        TheSurface.SetControlPoint i, 6, _
            1.25 * s - 1, y, 0
    Next i
End Sub
' ************************************************
' Set the control points for a hill.
' ************************************************
Sub MakeHill()
Dim i As Integer
Dim j As Integer

    TheSurface.SetBounds 4, 4
    ' Start flat and modify from there.
    For i = 1 To 4
        For j = 1 To 4
            TheSurface.SetControlPoint i, j, 2 * i - 5, 0, 2 * j - 5
        Next j
    Next i
    ' Make the modifications.
    TheSurface.SetControlPoint 2, 2, -1, 7, -1
    TheSurface.SetControlPoint 2, 3, -1, 7, 1
    TheSurface.SetControlPoint 3, 2, 1, 7, -1
    TheSurface.SetControlPoint 3, 3, 1, 7, 1
End Sub
Sub ShowViewingParameters()
    ShowingParameters = True
    RText.Text = Format$(EyeR, "0.0000")
    ThetaText.Text = Format$(EyeTheta, "0.0000")
    PhiText.Text = Format$(EyePhi, "0.0000")
    RText.Refresh
    ThetaText.Refresh
    PhiText.Refresh
    ShowingParameters = False
End Sub
Private Sub Choice_Click(Index As Integer)
    ChoiceNum = Index
    CreateData (ShowAxesCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft
            EyeTheta = EyeTheta - Dtheta

        Case vbKeyRight
            EyeTheta = EyeTheta + Dtheta

        Case vbKeyUp
            EyePhi = EyePhi - Dphi

        Case vbKeyDown
            EyePhi = EyePhi + Dphi

        Case Else
            Exit Sub
    End Select
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Asc("+")
            EyeR = EyeR + Dr

        Case Asc("-")
            EyeR = EyeR - Dr

        Case Else
            Exit Sub
    End Select
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub Form_Load()
    ' Initialize the eye position.
    EyeR = 10
    EyeTheta = PI * 0.2
    EyePhi = PI * 0.1
    ' Initialize the projection transformation.
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    ' Create the data.
    CreateData (ShowAxesCheck.value = vbChecked)
    ' Project and draw the data.
    Me.Show
    DrawData Pict
End Sub
' ************************************************
' Create the surface.
' ************************************************
Sub CreateData(show_axes As Boolean)
Const GapU = 0.1
Const GapV = 0.1
Const Du = GapU / 5
Const Dv = GapV / 5
Dim axis As ObjPolyline
    MousePointer = vbHourglass
    Refresh
    Set ThePicture = New ObjPicture
    Set TheSurface = New ObjBezier
    ThePicture.objects.Add TheSurface
    TheSurface.DrawControls = (ShowControlsCheck.value = vbChecked)
    TheSurface.DrawGrid = (ShowGridCheck.value = vbChecked)
    If show_axes Then
        Set axis = New ObjPolyline
        ThePicture.objects.Add axis
        axis.AddSegment 0, 0, 0, 5.5, 0, 0
        axis.AddSegment 0, 0, 0, 0, 3, 0
        axis.AddSegment 0, 0, 0, 0, 0, 5.5
    End If
    ' Set the control points.
    Select Case ChoiceNum
        Case 0  ' Hill.
            MakeHill
        Case 1  ' Wave.
            MakeWave
        Case 2  ' Tent.
            MakeTent

        Case 3  ' Curl.
            MakeCurl

        Case 4  ' Pipe.
            MakePipe

        Case 5  ' Cowling.
            MakeCowl

        Case 6  ' Twist.
            MakeTwist

        Case 7  ' Spiral.
            MakeSpiral

        Case 8  ' Urn.
            MakeUrn

        Case Else  ' Something safe.
            MakeHill
    End Select
    ' Create the grid to represent the surface.
    TheSurface.InitializeGrid GapU, GapV, Du, Dv
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
Private Sub mnuFileLoad_Click()
Dim fname As String
Dim filenum As Integer
Dim txt As String
Dim Xmin As Single
Dim ymin As Single
Dim Xmax As Single
Dim ymax As Single
    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)
    ' Clear the picture.
    Set ThePicture = Nothing
    ' Open the file.
    filenum = FreeFile
    Open fname For Input As #filenum
    ' Make sure it's an Object Picture File.
    Input #filenum, txt
    If txt <> "3D APF PICTURE" Then
        Close filenum
        Beep
        MsgBox "Error reading file """ & fname & """.", , vbExclamation
        Exit Sub
    End If
    ' Read the picture.
    MousePointer = vbHourglass
    DoEvents
    Set ThePicture = New ObjPicture
    ThePicture.FileInput filenum
    If ThePicture.objects(1).ObjectType = "BEZIER" Then
        Set TheSurface = ThePicture.objects(1)
        TheSurface.DrawControls = (ShowControlsCheck.value = vbChecked)
        TheSurface.DrawGrid = (ShowGridCheck.value = vbChecked)
    End If
    ' Close the file.
    Close filenum
    ' Refresh the display.
    DrawData Pict
    ' Deselect all the option buttons.
    For ChoiceNum = 0 To 8
        If Choice(ChoiceNum).value Then _
            Choice(ChoiceNum).value = False
    Next ChoiceNum
    MousePointer = vbDefault
End Sub
Private Sub mnuFileSaveAs_Click()
Dim fname As String
Dim filenum As Integer
    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)
    ' Open the file.
    filenum = FreeFile
    Open fname For Output As #filenum
    ' Write the picture.
    ThePicture.FileWrite filenum
    ' Close the file.
    Close filenum
End Sub
Private Sub PhiText_Change()
    If ShowingParameters Then Exit Sub
    EyePhi = CSng(PhiText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub RText_Change()
    If ShowingParameters Then Exit Sub
    EyeR = CSng(RText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub ShowAxesCheck_Click()
    CreateData (ShowAxesCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
Private Sub ShowControlsCheck_Click()
    TheSurface.DrawControls = (ShowControlsCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
Private Sub ShowGridCheck_Click()
    TheSurface.DrawGrid = (ShowGridCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
Private Sub ThetaText_Change()
    If ShowingParameters Then Exit Sub
    EyeTheta = CSng(ThetaText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub