Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH12/SRC/LIGHT1.FRM

Visual Basic Form | 1997-01-08 | 16.4 KB | 528 lines

VERSION 4.00
Begin VB.Form LightForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Light1"
   ClientHeight    =   6075
   ClientLeft      =   1335
   ClientTop       =   630
   ClientWidth     =   6030
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6765
   KeyPreview      =   -1  'True
   Left            =   1275
   LinkTopic       =   "Form1"
   ScaleHeight     =   6075
   ScaleWidth      =   6030
   Top             =   0
   Width           =   6150
   Begin VB.TextBox KText
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   480
      TabIndex        =   8
      Text            =   "0.75"
      Top             =   5760
      Width           =   855
   End
   Begin VB.TextBox PhiText
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   3600
      TabIndex        =   6
      Text            =   "0.1571"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox ThetaText
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   2040
      TabIndex        =   4
      Text            =   "1.8850"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox RText
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   480
      TabIndex        =   2
      Text            =   "20.0000"
      Top             =   5400
      Width           =   855
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   5295
      Left            =   0
      Picture         =   "Light1.frx":0000
      ScaleHeight     =   -14
      ScaleLeft       =   -7
      ScaleMode       =   0  'User
      ScaleTop        =   7
      ScaleWidth      =   15.926
      TabIndex        =   0
      Top             =   0
      Width           =   6015
   End
   Begin VB.Label Label1
      Caption         =   "d"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Index           =   3
      Left            =   240
      TabIndex        =   9
      Top             =   5880
      Width           =   135
   End
   Begin MSComDlg.CommonDialog LoadDialog
      Left            =   4560
      Top             =   5400
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "k"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Index           =   7
      Left            =   120
      TabIndex        =   7
      Top             =   5760
      Width           =   135
   End
   Begin VB.Label Label1
      Caption         =   "Phi"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Index           =   2
      Left            =   3240
      TabIndex        =   5
      Top             =   5400
      Width           =   375
   End
   Begin VB.Label Label1
      Caption         =   "Theta"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Index           =   1
      Left            =   1440
      TabIndex        =   3
      Top             =   5400
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "R"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      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 mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "LightForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim syspal(0 To 255) As PALETTEENTRY
' 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 ShowingParameters As Boolean
' *******************************************************
' Rotate the points in the cube and draw the cube.
' *******************************************************
Private Sub DrawData(pic As Object)
Dim X As Single
Dim Y As Single
Dim z As Single
Dim old_draw As Integer
Dim old_fill As Integer
Dim t1(1 To 4, 1 To 4) As Single
Dim t2(1 To 4, 1 To 4) As Single
Dim T12(1 To 4, 1 To 4) As Single
Dim T123(1 To 4, 1 To 4) As Single
Dim pt As Point3D
    MousePointer = vbHourglass
    ' Get the Kd for the surfaces.
    LightKd = CSng(KText.Text)
    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next
    ' Cull backfaces.
    ThePicture.Culled = False
    m3SphericalToCartesian EyeR, EyeTheta, EyePhi, X, Y, z
    ThePicture.Cull X, Y, z
    ' Clip faces behind the center of projection.
    ThePicture.ClipEye EyeR
    ' Transform coordinates into pixels.
    m3Scale t1, _
        Pict.ScaleX(1, Pict.ScaleMode, vbPixels), _
        Pict.ScaleY(1, Pict.ScaleMode, vbPixels), _
        1
    m3Translate t2, _
        -Pict.ScaleX(Pict.ScaleLeft, Pict.ScaleMode, vbPixels), _
        -Pict.ScaleY(Pict.ScaleTop, Pict.ScaleMode, vbPixels), _
        0
    m3MatMultiply T12, t1, t2
    m3MatMultiplyFull T123, Projector, T12
    ' Transform the points.
    ThePicture.ApplyFull T123
    ' Clear the screen. We must do this before
    ' selecting the pen and brush since Cls resets
    ' the pen and brush to default values.
    pic.Cls
    ' Prepare to fill polygons.
    old_draw = pic.DrawStyle
    old_fill = pic.FillStyle
    pic.DrawStyle = vbInvisible
    pic.FillStyle = vbFSSolid
    ' Display the data.
    ThePicture.DrawShaded pic, EyeR
    pic.Refresh
    ' Restore the old draw and fill styles.
    pic.DrawStyle = old_draw
    pic.FillStyle = old_fill
    ' Display the viewing parameters.
    ShowViewingParameters
    MousePointer = vbDefault
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 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()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Fill the picture's palette with grays.
    MatchGrayPalette Pict
    Pict.Cls
    ' Initialize the eye position.
    EyeR = 20
    EyeTheta = PI * 0.2
    EyePhi = PI * 0.05
    ' Initialize the projection transformation.
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
End Sub
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Leave new system palette entries in SysPal().
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim origpal(0 To 255) As PALETTEENTRY
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
Dim logpal As Long
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    status = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    status = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, origpal(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    logpal = pic.Picture.hPal
    If ResizePalette(logpal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        syspal(i) = origpal(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With syspal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        syspal(i) = origpal(i)
    Next i
    status = SetPaletteEntries(logpal, 0, SysPalSize, syspal(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With syspal(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    status = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, syspal(StaticColor1 + 1))
    ' Realize the gray palette.
    status = RealizePalette(pic.hdc)
    pic.Refresh
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
    LoadDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    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
        Caption = "Light1"
        Beep
        MsgBox "Error reading file """ & fname & """.", , vbExclamation
        Exit Sub
    End If
    ' Read the picture.
    Set ThePicture = New ObjPicture
    ThePicture.FileInput filenum
    ' Close the file.
    Close filenum
    Caption = "Light1 [" & LoadDialog.FileTitle & "]"
    ' Refresh the display.
    DrawData Pict
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 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