home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH13 / SRC / RAY1.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-08  |  25.9 KB  |  807 lines
  1. VERSION 4.00
  2. Begin VB.Form RayForm 
  3.    Appearance      =   0  'Flat
  4.    Caption         =   "Ray1"
  5.    ClientHeight    =   4005
  6.    ClientLeft      =   1980
  7.    ClientTop       =   1320
  8.    ClientWidth     =   5670
  9.    BeginProperty Font 
  10.       name            =   "MS Sans Serif"
  11.       charset         =   0
  12.       weight          =   700
  13.       size            =   8.25
  14.       underline       =   0   'False
  15.       italic          =   0   'False
  16.       strikethrough   =   0   'False
  17.    EndProperty
  18.    ForeColor       =   &H80000008&
  19.    Height          =   4695
  20.    KeyPreview      =   -1  'True
  21.    Left            =   1920
  22.    LinkTopic       =   "Form1"
  23.    ScaleHeight     =   267
  24.    ScaleMode       =   3  'Pixel
  25.    ScaleWidth      =   378
  26.    Top             =   690
  27.    Width           =   5790
  28.    Begin VB.OptionButton Scene 
  29.       Caption         =   "Overlapping"
  30.       BeginProperty Font 
  31.          name            =   "MS Sans Serif"
  32.          charset         =   0
  33.          weight          =   700
  34.          size            =   8.25
  35.          underline       =   0   'False
  36.          italic          =   0   'False
  37.          strikethrough   =   0   'False
  38.       EndProperty
  39.       Height          =   255
  40.       Index           =   3
  41.       Left            =   0
  42.       TabIndex        =   16
  43.       Top             =   1080
  44.       Width           =   1650
  45.    End
  46.    Begin VB.OptionButton Scene 
  47.       Caption         =   "Tetrahedron"
  48.       BeginProperty Font 
  49.          name            =   "MS Sans Serif"
  50.          charset         =   0
  51.          weight          =   700
  52.          size            =   8.25
  53.          underline       =   0   'False
  54.          italic          =   0   'False
  55.          strikethrough   =   0   'False
  56.       EndProperty
  57.       Height          =   255
  58.       Index           =   2
  59.       Left            =   0
  60.       TabIndex        =   15
  61.       Top             =   720
  62.       Width           =   1650
  63.    End
  64.    Begin VB.OptionButton Scene 
  65.       Caption         =   "Three in a Row"
  66.       BeginProperty Font 
  67.          name            =   "MS Sans Serif"
  68.          charset         =   0
  69.          weight          =   700
  70.          size            =   8.25
  71.          underline       =   0   'False
  72.          italic          =   0   'False
  73.          strikethrough   =   0   'False
  74.       EndProperty
  75.       Height          =   255
  76.       Index           =   1
  77.       Left            =   0
  78.       TabIndex        =   14
  79.       Top             =   360
  80.       Width           =   1650
  81.    End
  82.    Begin VB.OptionButton Scene 
  83.       Caption         =   "One Sphere"
  84.       BeginProperty Font 
  85.          name            =   "MS Sans Serif"
  86.          charset         =   0
  87.          weight          =   700
  88.          size            =   8.25
  89.          underline       =   0   'False
  90.          italic          =   0   'False
  91.          strikethrough   =   0   'False
  92.       EndProperty
  93.       Height          =   255
  94.       Index           =   0
  95.       Left            =   0
  96.       TabIndex        =   13
  97.       Top             =   0
  98.       Value           =   -1  'True
  99.       Width           =   1650
  100.    End
  101.    Begin VB.TextBox StepText 
  102.       BeginProperty Font 
  103.          name            =   "MS Sans Serif"
  104.          charset         =   0
  105.          weight          =   700
  106.          size            =   8.25
  107.          underline       =   0   'False
  108.          italic          =   0   'False
  109.          strikethrough   =   0   'False
  110.       EndProperty
  111.       Height          =   285
  112.       Left            =   600
  113.       TabIndex        =   11
  114.       Text            =   "4"
  115.       Top             =   3240
  116.       Width           =   855
  117.    End
  118.    Begin VB.CommandButton CmdGo 
  119.       Caption         =   "Go"
  120.       Default         =   -1  'True
  121.       BeginProperty Font 
  122.          name            =   "MS Sans Serif"
  123.          charset         =   0
  124.          weight          =   700
  125.          size            =   8.25
  126.          underline       =   0   'False
  127.          italic          =   0   'False
  128.          strikethrough   =   0   'False
  129.       EndProperty
  130.       Height          =   375
  131.       Left            =   360
  132.       TabIndex        =   10
  133.       Top             =   3600
  134.       Width           =   1095
  135.    End
  136.    Begin VB.TextBox KdistText 
  137.       BeginProperty Font 
  138.          name            =   "MS Sans Serif"
  139.          charset         =   0
  140.          weight          =   700
  141.          size            =   8.25
  142.          underline       =   0   'False
  143.          italic          =   0   'False
  144.          strikethrough   =   0   'False
  145.       EndProperty
  146.       Height          =   285
  147.       Left            =   600
  148.       TabIndex        =   7
  149.       Text            =   "-850"
  150.       Top             =   2640
  151.       Width           =   855
  152.    End
  153.    Begin VB.TextBox PhiText 
  154.       BeginProperty Font 
  155.          name            =   "MS Sans Serif"
  156.          charset         =   0
  157.          weight          =   700
  158.          size            =   8.25
  159.          underline       =   0   'False
  160.          italic          =   0   'False
  161.          strikethrough   =   0   'False
  162.       EndProperty
  163.       Height          =   285
  164.       Left            =   600
  165.       TabIndex        =   6
  166.       Text            =   "-0.4713"
  167.       Top             =   2160
  168.       Width           =   855
  169.    End
  170.    Begin VB.TextBox ThetaText 
  171.       BeginProperty Font 
  172.          name            =   "MS Sans Serif"
  173.          charset         =   0
  174.          weight          =   700
  175.          size            =   8.25
  176.          underline       =   0   'False
  177.          italic          =   0   'False
  178.          strikethrough   =   0   'False
  179.       EndProperty
  180.       Height          =   285
  181.       Left            =   600
  182.       TabIndex        =   4
  183.       Text            =   "0.6275"
  184.       Top             =   1800
  185.       Width           =   855
  186.    End
  187.    Begin VB.TextBox RText 
  188.       BeginProperty Font 
  189.          name            =   "MS Sans Serif"
  190.          charset         =   0
  191.          weight          =   700
  192.          size            =   8.25
  193.          underline       =   0   'False
  194.          italic          =   0   'False
  195.          strikethrough   =   0   'False
  196.       EndProperty
  197.       Height          =   285
  198.       Left            =   600
  199.       TabIndex        =   2
  200.       Text            =   "1000"
  201.       Top             =   1440
  202.       Width           =   855
  203.    End
  204.    Begin VB.PictureBox Pict 
  205.       AutoRedraw      =   -1  'True
  206.       BackColor       =   &H00FFFF80&
  207.       BeginProperty Font 
  208.          name            =   "MS Sans Serif"
  209.          charset         =   0
  210.          weight          =   700
  211.          size            =   8.25
  212.          underline       =   0   'False
  213.          italic          =   0   'False
  214.          strikethrough   =   0   'False
  215.       EndProperty
  216.       Height          =   3975
  217.       Left            =   1680
  218.       Picture         =   "Ray1.frx":0000
  219.       ScaleHeight     =   261
  220.       ScaleMode       =   3  'Pixel
  221.       ScaleWidth      =   261
  222.       TabIndex        =   0
  223.       Top             =   0
  224.       Width           =   3975
  225.    End
  226.    Begin VB.Label Label1 
  227.       Caption         =   "Step"
  228.       BeginProperty Font 
  229.          name            =   "MS Sans Serif"
  230.          charset         =   0
  231.          weight          =   700
  232.          size            =   8.25
  233.          underline       =   0   'False
  234.          italic          =   0   'False
  235.          strikethrough   =   0   'False
  236.       EndProperty
  237.       Height          =   255
  238.       Index           =   13
  239.       Left            =   0
  240.       TabIndex        =   12
  241.       Top             =   3240
  242.       Width           =   615
  243.    End
  244.    Begin VB.Label Label1 
  245.       Caption         =   "dist"
  246.       BeginProperty Font 
  247.          name            =   "MS Sans Serif"
  248.          charset         =   0
  249.          weight          =   700
  250.          size            =   8.25
  251.          underline       =   0   'False
  252.          italic          =   0   'False
  253.          strikethrough   =   0   'False
  254.       EndProperty
  255.       Height          =   255
  256.       Index           =   8
  257.       Left            =   120
  258.       TabIndex        =   9
  259.       Top             =   2760
  260.       Width           =   375
  261.    End
  262.    Begin VB.Label Label1 
  263.       Caption         =   "k"
  264.       BeginProperty Font 
  265.          name            =   "MS Sans Serif"
  266.          charset         =   0
  267.          weight          =   700
  268.          size            =   8.25
  269.          underline       =   0   'False
  270.          italic          =   0   'False
  271.          strikethrough   =   0   'False
  272.       EndProperty
  273.       Height          =   255
  274.       Index           =   6
  275.       Left            =   0
  276.       TabIndex        =   8
  277.       Top             =   2640
  278.       Width           =   135
  279.    End
  280.    Begin MSComDlg.CommonDialog LoadDialog 
  281.       Left            =   -240
  282.       Top             =   3720
  283.       _Version        =   65536
  284.       _ExtentX        =   847
  285.       _ExtentY        =   847
  286.       _StockProps     =   0
  287.       CancelError     =   -1  'True
  288.    End
  289.    Begin VB.Label Label1 
  290.       Caption         =   "Phi"
  291.       BeginProperty Font 
  292.          name            =   "MS Sans Serif"
  293.          charset         =   0
  294.          weight          =   700
  295.          size            =   8.25
  296.          underline       =   0   'False
  297.          italic          =   0   'False
  298.          strikethrough   =   0   'False
  299.       EndProperty
  300.       Height          =   255
  301.       Index           =   2
  302.       Left            =   0
  303.       TabIndex        =   5
  304.       Top             =   2160
  305.       Width           =   375
  306.    End
  307.    Begin VB.Label Label1 
  308.       Caption         =   "Theta"
  309.       BeginProperty Font 
  310.          name            =   "MS Sans Serif"
  311.          charset         =   0
  312.          weight          =   700
  313.          size            =   8.25
  314.          underline       =   0   'False
  315.          italic          =   0   'False
  316.          strikethrough   =   0   'False
  317.       EndProperty
  318.       Height          =   255
  319.       Index           =   1
  320.       Left            =   0
  321.       TabIndex        =   3
  322.       Top             =   1800
  323.       Width           =   495
  324.    End
  325.    Begin VB.Label Label1 
  326.       Caption         =   "R"
  327.       BeginProperty Font 
  328.          name            =   "MS Sans Serif"
  329.          charset         =   0
  330.          weight          =   700
  331.          size            =   8.25
  332.          underline       =   0   'False
  333.          italic          =   0   'False
  334.          strikethrough   =   0   'False
  335.       EndProperty
  336.       Height          =   255
  337.       Index           =   0
  338.       Left            =   0
  339.       TabIndex        =   1
  340.       Top             =   1440
  341.       Width           =   255
  342.    End
  343.    Begin VB.Menu mnuFile 
  344.       Caption         =   "&File"
  345.       Begin VB.Menu mnuFileSaveBitmap 
  346.          Caption         =   "&Save Bitmap..."
  347.          Shortcut        =   ^S
  348.       End
  349.       Begin VB.Menu mnuFileSep 
  350.          Caption         =   "-"
  351.       End
  352.       Begin VB.Menu mnuFileExit 
  353.          Caption         =   "E&xit"
  354.       End
  355.    End
  356. Attribute VB_Name = "RayForm"
  357. Attribute VB_Creatable = False
  358. Attribute VB_Exposed = False
  359. Option Explicit
  360. Dim SysPalSize As Integer
  361. Dim NumStaticColors As Integer
  362. Dim StaticColor1 As Integer
  363. Dim StaticColor2 As Integer
  364. Dim syspal(0 To 255) As PALETTEENTRY
  365. ' Location of viewing eye.
  366. Dim EyeR As Single
  367. Dim EyeTheta As Single
  368. Dim EyePhi As Single
  369. Const dtheta = PI / 20
  370. Const Dphi = PI / 20
  371. Const dR = 1
  372. ' Location of focus point.
  373. Const FocusX = 0#
  374. Const FocusY = 0#
  375. Const FocusZ = 0#
  376. Dim Projector(1 To 4, 1 To 4) As Single
  377. ' The collection of objects in the scene.
  378. Dim Objects As Collection
  379. Dim Running As Boolean
  380. Dim SceneChoice As Integer
  381. ' ************************************************
  382. ' Halt immediately in case we're in the middle of
  383. ' ray tracing.
  384. ' ************************************************
  385. Private Sub Form_Unload(Cancel As Integer)
  386.     End
  387. End Sub
  388. ' ************************************************
  389. ' Create the objects in the scene.
  390. ' ************************************************
  391. Sub CreateData()
  392. Dim sphere As ObjSphere
  393.     Set Objects = New Collection
  394.     Select Case SceneChoice
  395.         Case 0  ' One sphere.
  396.             ' Sphere of radius 60 at (0, 0, 0).
  397.             Set sphere = New ObjSphere
  398.             Objects.Add sphere
  399.             sphere.Initialize 60, 0, 0, 0
  400.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  401.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  402.             sphere.SetSpec 20, 0.35         ' Specular.
  403.         Case 1  ' Three in a row.
  404.             ' Sphere of radius 50 at (0, 0, 100).
  405.             Set sphere = New ObjSphere
  406.             Objects.Add sphere
  407.             sphere.Initialize 50, 0, 0, 100
  408.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  409.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  410.             sphere.SetSpec 20, 0.35         ' Specular.
  411.         
  412.             ' Sphere of radius 50 at (0, 0, -100).
  413.             Set sphere = New ObjSphere
  414.             Objects.Add sphere
  415.             sphere.Initialize 50, 0, 0, -100
  416.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  417.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  418.             sphere.SetSpec 20, 0.35         ' Specular.
  419.         
  420.             ' Sphere of radius 50 at (0, 0, 0).
  421.             Set sphere = New ObjSphere
  422.             Objects.Add sphere
  423.             sphere.Initialize 50, 0, 0, 0
  424.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  425.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  426.             sphere.SetSpec 20, 0.35         ' Specular.
  427.         Case 2  ' Tetrahedron.
  428.             ' Sphere of radius 45 at (0, -51.65, 0).
  429.             Set sphere = New ObjSphere
  430.             Objects.Add sphere
  431.             sphere.Initialize 45, 0, -51.65, 0
  432.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  433.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  434.             sphere.SetSpec 20, 0.35         ' Specular.
  435.         
  436.             ' Sphere of radius 45 at (57.74, 30, 0).
  437.             Set sphere = New ObjSphere
  438.             Objects.Add sphere
  439.             sphere.Initialize 45, 57.74, 30, 0
  440.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  441.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  442.             sphere.SetSpec 20, 0.35         ' Specular.
  443.         
  444.             ' Sphere of radius 45 at (-28.87, 30, 50).
  445.             Set sphere = New ObjSphere
  446.             Objects.Add sphere
  447.             sphere.Initialize 45, -28.87, 30, 50
  448.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  449.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  450.             sphere.SetSpec 20, 0.35         ' Specular.
  451.         
  452.             ' Sphere of radius 45 at (-28.87, 30, -50).
  453.             Set sphere = New ObjSphere
  454.             Objects.Add sphere
  455.             sphere.Initialize 45, -28.87, 30, -50
  456.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  457.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  458.             sphere.SetSpec 20, 0.35         ' Specular.
  459.         Case 3  ' Overlapping.
  460.             ' Sphere of radius 60 at (-40, 0, 0).
  461.             Set sphere = New ObjSphere
  462.             Objects.Add sphere
  463.             sphere.Initialize 60, -40, 0, 0
  464.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  465.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  466.             sphere.SetSpec 20, 0.35         ' Specular.
  467.         
  468.             ' Sphere of radius 60 at (40, 0, 0).
  469.             Set sphere = New ObjSphere
  470.             Objects.Add sphere
  471.             sphere.Initialize 60, 40, 0, 0
  472.             sphere.SetKd 0.45, 0.45, 0.45   ' Diffuse.
  473.             sphere.SetKa 0.4, 0.4, 0.4      ' Ambient.
  474.             sphere.SetSpec 20, 0.35         ' Specular.
  475.         
  476.     End Select
  477. End Sub
  478. ' *******************************************************
  479. ' Project and draw.
  480. ' *******************************************************
  481. Private Sub DrawData(pic As Object)
  482. Dim Projector(1 To 4, 1 To 4) As Single
  483. Dim obj As Object
  484. Dim factor As Single
  485.     ' Get the current eye location.
  486.     EyeR = CSng(RText.Text)
  487.     EyeTheta = CSng(ThetaText.Text)
  488.     EyePhi = CSng(PhiText.Text)
  489.     ' Create the data.
  490.     CreateData
  491.     ' Get constants for the surfaces.
  492.     LightKdist = CSng(KdistText.Text)
  493.     ' Create a background color.
  494.     BackR = 0
  495.     BackG = 0
  496.     BackB = 0
  497.     ' Fill with another color so we can see progress.
  498.     pic.Line (pic.ScaleLeft, pic.ScaleTop)- _
  499.         Step(pic.ScaleWidth, pic.ScaleHeight), _
  500.         RGB(0, 0, &H80), BF
  501.     ' Rotate the eye onto the Z axis.
  502.     m3PProject Projector, m3Parallel, _
  503.         EyeR, EyePhi, EyeTheta, _
  504.         FocusX, FocusY, FocusZ, _
  505.         0, 1, 0
  506.     ' Transform the objects.
  507.     For Each obj In Objects
  508.         obj.Apply Projector
  509.     Next obj
  510.     ' Transform the light source.
  511.     m3Apply LightSource.coord, Projector, LightSource.trans
  512.     ' Adjust the incident light values.
  513.     factor = _
  514.         Sqr(LightSource.trans(1) * LightSource.trans(1) + _
  515.             LightSource.trans(2) * LightSource.trans(2) + _
  516.             LightSource.trans(3) * LightSource.trans(3)) _
  517.             + LightKdist + 4
  518.     LightIir = 255 * factor
  519.     LightIig = 255 * factor
  520.     LightIib = 255 * factor
  521.     ' Display the data.
  522.     RayTrace pic, CInt(StepText.Text)
  523.     ' Display the viewing parameters.
  524.     ShowViewingParameters
  525. End Sub
  526. ' ************************************************
  527. ' Start ray tracing for this picture box.
  528. ' ************************************************
  529. Sub RayTrace(pic As PictureBox, skip As Integer)
  530. Dim x As Integer
  531. Dim y As Integer
  532. Dim xmax As Integer
  533. Dim ymax As Integer
  534. Dim xoff As Integer
  535. Dim yoff As Integer
  536.     ' Get the transformed coordinates of the eye.
  537.     EyeX = 0
  538.     EyeY = 0
  539.     EyeZ = EyeR
  540.     xoff = pic.ScaleWidth / 2
  541.     yoff = pic.ScaleHeight / 2
  542.     xmax = pic.ScaleLeft + pic.ScaleWidth - 1
  543.     ymax = pic.ScaleTop + pic.ScaleHeight - 1
  544.     For y = pic.ScaleTop To ymax Step skip
  545.         For x = pic.ScaleLeft To xmax Step skip
  546.             ' Calculate the value of pixel (x, y).
  547.             ' After transformation the eye is
  548.             ' at (0, 0, EyeR) and the plane of
  549.             ' projection lies in the X-Y plane.
  550.             If skip < 2 Then
  551.                 pic.PSet (x, y), _
  552.                     TraceRay(0, 0, EyeR, CSng(x) - xoff, CSng(y) - yoff, -EyeR)
  553.                 Else
  554.                     pic.Line (x, y)-Step(skip - 1, skip - 1), _
  555.                         TraceRay(0, 0, EyeR, CSng(x) - xoff, CSng(y) - yoff, -EyeR), BF
  556.                 End If
  557.         Next x
  558.         
  559.         ' Let the user see what's going on.
  560.         pic.Refresh
  561.         
  562.         ' If the Stop button was pressed, stop.
  563.         DoEvents
  564.         If Not Running Then Exit Sub
  565.     Next y
  566. End Sub
  567. Sub ShowViewingParameters()
  568.     RText.Text = Format$(EyeR, "0")
  569.     ThetaText.Text = Format$(EyeTheta, "0.0000")
  570.     PhiText.Text = Format$(EyePhi, "0.0000")
  571.     RText.Refresh
  572.     ThetaText.Refresh
  573.     PhiText.Refresh
  574. End Sub
  575. ' ************************************************
  576. ' Return the pixel color given by tracing from
  577. ' point (px, py, pz) in direction <vx, vy, vz>.
  578. ' ************************************************
  579. Function TraceRay(px As Single, py As Single, pz As Single, Vx As Single, Vy As Single, Vz As Single) As Long
  580. Dim i As Integer
  581. Dim best_i As Integer
  582. Dim best_dist As Single
  583. Dim dist As Single
  584. Dim R As Integer
  585. Dim G As Integer
  586. Dim B As Integer
  587.     If Objects.Count < 1 Then Exit Function
  588.     ' Find the object that's closest.
  589.     best_dist = INFINITY
  590.     best_i = -1
  591.     For i = 1 To Objects.Count
  592.         dist = Objects.Item(i).RayDistance( _
  593.             px, py, pz, Vx, Vy, Vz)
  594.         If best_dist > dist Then
  595.             best_dist = dist
  596.             best_i = i
  597.         End If
  598.     Next i
  599.     ' If we hit nothing, return the background color.
  600.     If best_i < 1 Then
  601.         TraceRay = &H2000000 + _
  602.             RGB(BackR, BackG, BackB)
  603.         Exit Function
  604.     End If
  605.     ' Compute the color at that point.
  606.     Objects.Item(best_i).HitColor Objects, R, G, B
  607.     ' This is a problem for some values of LightKdist.
  608.     If R < 0 Then R = 0
  609.     If G < 0 Then G = 0
  610.     If B < 0 Then B = 0
  611.     TraceRay = &H2000000 + RGB(R, G, B)
  612. End Function
  613. ' ************************************************
  614. ' Do the ray tracing.
  615. ' ************************************************
  616. Private Sub CmdGo_Click()
  617.     If Running Then
  618.         Running = False
  619.         CmdGo.Caption = "Stopped"
  620.         CmdGo.Enabled = False
  621.         DoEvents
  622.     Else
  623.         Running = True
  624.         CmdGo.Caption = "Stop"
  625.         MousePointer = vbHourglass
  626.         DoEvents
  627.         
  628.         DrawData Pict
  629.         
  630.         MousePointer = vbDefault
  631.         CmdGo.Enabled = True
  632.         CmdGo.Caption = "Go"
  633.         Running = False
  634.         Beep
  635.     End If
  636. End Sub
  637. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  638.     Select Case KeyCode
  639.         Case vbKeyLeft
  640.             EyeTheta = EyeTheta - dtheta
  641.         
  642.         Case vbKeyRight
  643.             EyeTheta = EyeTheta + dtheta
  644.         
  645.         Case vbKeyUp
  646.             EyePhi = EyePhi - Dphi
  647.         
  648.         Case vbKeyDown
  649.             EyePhi = EyePhi + Dphi
  650.                 
  651.         Case Else
  652.             Exit Sub
  653.     End Select
  654.     ShowViewingParameters
  655. End Sub
  656. Private Sub Form_KeyPress(KeyAscii As Integer)
  657.     Select Case KeyAscii
  658.         Case Asc("+")
  659.             EyeR = EyeR + dR
  660.         
  661.         Case Asc("-")
  662.             EyeR = EyeR - dR
  663.         
  664.         Case Else
  665.             Exit Sub
  666.     End Select
  667.     ShowViewingParameters
  668. End Sub
  669. Private Sub Form_Load()
  670.     ' Make sure the screen supports palettes.
  671.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  672.         Beep
  673.         MsgBox "This monitor does not support palettes.", _
  674.             vbCritical
  675.         End
  676.     End If
  677.     ' Get system palette size and # static colors.
  678.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  679.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  680.     StaticColor1 = NumStaticColors \ 2 - 1
  681.     StaticColor2 = SysPalSize - NumStaticColors \ 2
  682.     ' Fill the picture's palette with grays.
  683.     MatchGrayPalette Pict
  684.     Pict.Cls
  685.     ' Initialize lighting constants.
  686.     LightSource.coord(1) = 100
  687.     LightSource.coord(2) = -500
  688.     LightSource.coord(3) = 1000
  689.     LightSource.coord(4) = 1
  690.     LightIar = 128
  691.     LightIag = 128
  692.     LightIab = 128
  693.     ' Initialize the eye position.
  694.     EyeR = CSng(RText.Text)
  695.     EyeTheta = CSng(ThetaText.Text)
  696.     EyePhi = CSng(PhiText.Text)
  697.     ' Initialize the projection transformation.
  698.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  699. End Sub
  700. ' ***********************************************
  701. ' Load the control's palette so the non-static
  702. ' colors are grays. Map the logical palette to
  703. ' match the system palette. Convert the image to
  704. ' use the non-static grays.
  705. ' Leave new system palette entries in SysPal().
  706. ' ***********************************************
  707. Sub MatchGrayPalette(pic As Control)
  708. Dim origpal(0 To 255) As PALETTEENTRY
  709. Dim wid As Long
  710. Dim hgt As Long
  711. Dim bytes() As Byte
  712. Dim i As Integer
  713. Dim bm As BITMAP
  714. Dim hbm As Integer
  715. Dim status As Long
  716. Dim x As Integer
  717. Dim y As Integer
  718. Dim gray As Single
  719. Dim dgray As Single
  720. Dim C As Integer
  721. Dim clr As Integer
  722. Dim logpal As Long
  723.     ' Make sure pic has the foreground palette.
  724.     pic.ZOrder
  725.     status = RealizePalette(pic.hdc)
  726.     DoEvents
  727.     ' Get the system palette entries.
  728.     status = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, origpal(0))
  729.         
  730.     ' Get the image pixels.
  731.     hbm = pic.Image
  732.     status = GetObject(hbm, BITMAP_SIZE, bm)
  733.     wid = bm.bmWidthBytes
  734.     hgt = bm.bmHeight
  735.     ReDim bytes(1 To wid, 1 To hgt)
  736.     status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  737.     ' Make the logical palette as big as possible.
  738.     logpal = pic.Picture.hPal
  739.     If ResizePalette(logpal, SysPalSize) = 0 Then
  740.         Beep
  741.         MsgBox "Error resizing logical palette.", _
  742.             vbExclamation
  743.         Exit Sub
  744.     End If
  745.     ' Blank the non-static colors.
  746.     For i = 0 To StaticColor1
  747.         syspal(i) = origpal(i)
  748.     Next i
  749.     For i = StaticColor1 + 1 To StaticColor2 - 1
  750.         With syspal(i)
  751.             .peRed = 0
  752.             .peGreen = 0
  753.             .peBlue = 0
  754.             .peFlags = PC_NOCOLLAPSE
  755.         End With
  756.     Next i
  757.     For i = StaticColor2 To 255
  758.         syspal(i) = origpal(i)
  759.     Next i
  760.     status = SetPaletteEntries(logpal, 0, SysPalSize, syspal(0))
  761.     ' Insert the non-static grays.
  762.     gray = 0
  763.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  764.     For i = StaticColor1 + 1 To StaticColor2 - 1
  765.         C = gray
  766.         gray = gray + dgray
  767.         With syspal(i)
  768.             .peRed = C
  769.             .peGreen = C
  770.             .peBlue = C
  771.         End With
  772.     Next i
  773.     status = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, syspal(StaticColor1 + 1))
  774.     ' Realize the gray palette.
  775.     status = RealizePalette(pic.hdc)
  776.     pic.Refresh
  777. End Sub
  778. Private Sub mnuFileExit_Click()
  779.     Unload Me
  780. End Sub
  781. Private Sub mnuFileSaveBitmap_Click()
  782. Dim fname As String
  783.     ' Allow the user to pick a file.
  784.     On Error Resume Next
  785.     LoadDialog.filename = "*.BMP"
  786.     LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  787.     LoadDialog.ShowSave
  788.     If Err.Number = cdlCancel Then
  789.         Unload LoadDialog
  790.         Exit Sub
  791.     ElseIf Err.Number <> 0 Then
  792.         Unload LoadDialog
  793.         Beep
  794.         MsgBox "Error selecting file.", , vbExclamation
  795.         Exit Sub
  796.     End If
  797.     On Error GoTo 0
  798.     fname = LoadDialog.filename
  799.     SavePicture Pict.Image, fname
  800. End Sub
  801. ' ************************************************
  802. ' Select this choice.
  803. ' ************************************************
  804. Private Sub Scene_Click(Index As Integer)
  805.     SceneChoice = Index
  806. End Sub
  807.