Visual Basic Graphics Programming (2nd Edition)

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH13 / SRC / RRAY2.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1997-01-08 | 32.5 KB | 999 lines

VERSION 4.00 Begin VB.Form RayForm Appearance = 0 'Flat Caption = "RRay2" ClientHeight = 4590 ClientLeft = 1830 ClientTop = 1260 ClientWidth = 6030 DrawMode = 14 'Copy Pen 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 = 5280 KeyPreview = -1 'True Left = 1770 LinkTopic = "Form1" ScaleHeight = 306 ScaleMode = 3 'Pixel ScaleWidth = 402 Top = 630 Width = 6150 Begin VB.OptionButton Scene Caption = "Sphere + Prism" 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 = 4 Left = 0 TabIndex = 19 Top = 1440 Width = 2025 End Begin VB.PictureBox Pict AutoRedraw = -1 'True BackColor = &H00FFFF80& BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 3975 Left = 2040 Picture = "RRay2.frx":0000 ScaleHeight = 261 ScaleMode = 3 'Pixel ScaleWidth = 261 TabIndex = 11 Top = 0 Width = 3975 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 = 840 TabIndex = 10 Text = "1000" Top = 1800 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 = 840 TabIndex = 9 Text = "0.6275" Top = 2160 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 = 840 TabIndex = 8 Text = "-0.4713" Top = 2520 Width = 855 End Begin VB.TextBox KdistText 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 = 840 TabIndex = 7 Text = "-850" Top = 3000 Width = 855 End Begin VB.CommandButton CmdGo Caption = "Go" Default = -1 'True BeginProperty Font name = "MS Sans Serif" charset = 0 weight = 700 size = 8.25 underline = 0 'False italic = 0 'False strikethrough = 0 'False EndProperty Height = 375 Left = 600 TabIndex = 6 Top = 4200 Width = 1095 End Begin VB.TextBox StepText 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 = 840 TabIndex = 5 Text = "4" Top = 3840 Width = 855 End Begin VB.OptionButton Scene Caption = "Spheres Over Plane" 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 = 0 TabIndex = 4 Top = 0 Value = -1 'True Width = 2025 End Begin VB.OptionButton Scene Caption = "Spheres + Square" 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 = 0 TabIndex = 3 Top = 360 Width = 2025 End Begin VB.OptionButton Scene Caption = "Three Spheres" 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 = 0 TabIndex = 2 Top = 720 Width = 2025 End Begin VB.OptionButton Scene Caption = "Sphere + Cylinder" 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 = 0 TabIndex = 1 Top = 1080 Width = 2025 End Begin VB.TextBox DepthText 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 = 840 TabIndex = 0 Text = "1" Top = 3480 Width = 855 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 = 18 Top = 1800 Width = 255 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 = 240 TabIndex = 17 Top = 2160 Width = 495 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 = 240 TabIndex = 16 Top = 2520 Width = 375 End Begin MSComDlg.CommonDialog LoadDialog Left = 0 Top = 4320 _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 = 6 Left = 240 TabIndex = 15 Top = 3000 Width = 135 End Begin VB.Label Label1 Caption = "dist" 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 = 8 Left = 360 TabIndex = 14 Top = 3120 Width = 375 End Begin VB.Label Label1 Caption = "Step" 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 = 13 Left = 240 TabIndex = 13 Top = 3840 Width = 615 End Begin VB.Label Label1 Caption = "Depth" 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 = 12 Top = 3480 Width = 615 End Begin VB.Menu mnuFile Caption = "&File" Begin VB.Menu mnuFileSaveBitmap Caption = "&Save Bitmap..." Shortcut = ^S End Begin VB.Menu mnuFileSep Caption = "-" End Begin VB.Menu mnuFileExit Caption = "E&xit" End End Attribute VB_Name = "RayForm" 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 Running As Boolean Dim SceneChoice As Integer ' ************************************************ ' Create the objects in the scene. ' ************************************************ Sub CreateData() Dim obj As Object Dim s As Single Dim i As Integer Dim j As Integer Dim j1 As Integer Dim x1 As Single Dim x2 As Single Dim xmid As Single Dim y1 As Single Dim y2 As Single Dim z1 As Single Dim z2 As Single Set Objects = New Collection Select Case SceneChoice Case 0 ' 2 Spheres + Plane. ' Reflective sphere of radius 40 at ' (-40, -40, 0). Set obj = New ObjSphere Objects.Add obj obj.Initialize 40, -40, -40, 0 obj.SetKd 0.45, 0.45, 0.45 ' Diffuse. obj.SetKa 0.4, 0.4, 0.4 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.5, 0.5, 0.5 ' Reflected. ' Transparent sphere of radius 40 at ' (40, -40, 0). Set obj = New ObjSphere Objects.Add obj obj.Initialize 40, 40, -40, 0 obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. ' Relfective X-Z plane. Set obj = New ObjPlane Objects.Add obj obj.Initialize 0, 0, 0, 0, -1, 0 obj.SetKd 0.3, 0.3, 0.3 ' Diffuse. obj.SetKa 0.2, 0.2, 0.2 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.5, 0.5, 0.5 ' Reflected. Case 1 ' Spheres + Square. ' Non-reflective sphere of radius 30 ' at (50, 20, -50). Set obj = New ObjSphere Objects.Add obj obj.Initialize 30, 50, 20, -50 obj.SetKd 0.45, 0.45, 0.45 ' Diffuse. obj.SetKa 0.4, 0.4, 0.4 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. ' Non-reflective sphere of radius 40 ' at (-50, 40, -30). Set obj = New ObjSphere Objects.Add obj obj.Initialize 40, -50, 40, -30 obj.SetKd 0.45, 0.45, 0.45 ' Diffuse. obj.SetKa 0.4, 0.4, 0.4 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. ' Half-silvered square in the Y-Z plane. s = 100 Set obj = New ObjPolygon Objects.Add obj obj.AddPoint _ 0, s, s, _ 0, -s, s, _ 0, -s, -s, _ 0, s, -s obj.DefinePlane obj.SetKd 0.2, 0.2, 0.2 ' Diffuse. obj.SetKa 0.2, 0.2, 0.2 ' Ambient. obj.SetSpec 20, 0.5 ' Specular. obj.SetKr 0.5, 0.5, 0.5 ' Reflected. obj.SetKt 10, 1, 1, _ 0.5, 0.5, 0.5 ' Transmitted. Case 2 ' Three Spheres. ' Reflective sphere of radius 50 at ' (-50, -50, -50). Set obj = New ObjSphere Objects.Add obj obj.Initialize 50, -50, -50, -50 obj.SetKd 0.45, 0.45, 0.45 ' Diffuse. obj.SetKa 0.4, 0.4, 0.4 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.75, 0.75, 0.75 ' Reflected. ' Non-reflective sphere of radius 40 at ' (-40, -40, 40). Set obj = New ObjSphere Objects.Add obj obj.Initialize 40, -40, -40, 40 obj.SetKd 0.45, 0.45, 0.45 ' Diffuse. obj.SetKa 0.4, 0.4, 0.4 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. ' Transparent sphere of radius 40 at ' (40, -40, 0). Set obj = New ObjSphere Objects.Add obj obj.Initialize 40, 40, -40, 0 obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.3 ' Specular. obj.SetKr 0.1, 0.1, 0.1 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. ' Relfective X-Z plane. Set obj = New ObjPlane Objects.Add obj obj.Initialize 0, 0, 0, 0, -1, 0 obj.SetKd 0.3, 0.3, 0.3 ' Diffuse. obj.SetKa 0.2, 0.2, 0.2 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.4, 0.4, 0.4 ' Reflected. Case 3 ' Sphere + Cylinder. ' Transparent cylinder of radius 30 ' between (-900, 1000, 0) and (1100, -1000, 0). Set obj = New ObjCylinder Objects.Add obj obj.Initialize 30, -900, 1000, 0, 1100, -1000, 0 obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.5 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. ' Transparent sphere of radius 60 at ' (-50, -50, 0). Set obj = New ObjSphere Objects.Add obj obj.Initialize 60, -50, -50, 0 obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. ' Make some non-reflective stripes. s = 20 For i = -6 * s To 6 * s Step 2 * s ' Make a rectangle. Set obj = New ObjPolygon Objects.Add obj obj.AddPoint _ i, -1000, -20, _ i + s, -1000, -20, _ i + s, 1000, -20, _ i, 1000, -20 obj.DefinePlane obj.SetKd 0.5, 0.5, 0.5 ' Diffuse. obj.SetKa 0.5, 0.5, 0.5 ' Ambient. obj.SetSpec 20, 0.1 ' Specular. Next i Case 4 ' Sphere + Prism. ' Non-reflective sphere of radius 50 ' at (-50, -50, 0). Set obj = New ObjSphere Objects.Add obj obj.Initialize 50, -50, -50, 0 obj.SetKd 0.45, 0.45, 0.45 ' Diffuse. obj.SetKa 0.4, 0.4, 0.4 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. ' Transparent prism. x1 = 15 x2 = 45 y1 = 0 y2 = -100 z1 = -50 z2 = 50 xmid = (x1 + x2) / 2 Set obj = New ObjFace Objects.Add obj obj.AddPoint _ x1, y1, z1, _ x1, y2, z1, _ x2, y2, z1, _ x2, y1, z1 obj.DefinePlane obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. Set obj = New ObjFace Objects.Add obj obj.AddPoint _ xmid, y1, z2, _ x2, y1, z1, _ x2, y2, z1, _ xmid, y2, z2 obj.DefinePlane obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. Set obj = New ObjFace Objects.Add obj obj.AddPoint _ xmid, y2, z2, _ x2, y2, z1, _ x1, y2, z1 obj.DefinePlane obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. Set obj = New ObjFace Objects.Add obj obj.AddPoint _ x1, y1, z1, _ x2, y1, z1, _ xmid, y1, z2 obj.DefinePlane obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. Set obj = New ObjFace Objects.Add obj obj.AddPoint _ xmid, y2, z2, _ x1, y2, z1, _ x1, y1, z1, _ xmid, y1, z2 obj.DefinePlane obj.SetKd 0.1, 0.1, 0.1 ' Diffuse. obj.SetKa 0.1, 0.1, 0.1 ' Ambient. obj.SetSpec 20, 0.35 ' Specular. obj.SetKr 0.2, 0.2, 0.2 ' Reflected. obj.SetKt 10, 1, 1.4, _ 1, 1, 1 ' Transmitted. End Select End Sub ' ******************************************************* ' Project and draw. ' ******************************************************* Private Sub DrawData(pic As Object) Dim Projector(1 To 4, 1 To 4) As Single Dim obj As Object Dim factor As Single ' Get the current eye location. EyeR = CSng(RText.Text) EyeTheta = CSng(ThetaText.Text) EyePhi = CSng(PhiText.Text) ' Create the data. CreateData ' Get constants for the surfaces. LightKdist = CSng(KdistText.Text) ' Create a background color. BackR = 0 BackG = 0 BackB = 0 ' Fill with another color so we can see progress. pic.Line (pic.ScaleLeft, pic.ScaleTop)- _ Step(pic.ScaleWidth, pic.ScaleHeight), _ RGB(0, 0, &H80), BF ' Rotate the eye onto the Z axis. m3PProject Projector, m3Parallel, _ EyeR, EyePhi, EyeTheta, _ FocusX, FocusY, FocusZ, _ 0, 1, 0 ' Transform the objects. For Each obj In Objects obj.Apply Projector Next obj ' Transform the light source. m3Apply LightSource.coord, Projector, LightSource.trans ' Adjust the incident light values. factor = _ Sqr(LightSource.trans(1) * LightSource.trans(1) + _ LightSource.trans(2) * LightSource.trans(2) + _ LightSource.trans(3) * LightSource.trans(3)) _ + LightKdist + 4 LightIir = 255 * factor LightIig = 255 * factor LightIib = 255 * factor ' Display the data. RayTrace pic, CInt(StepText.Text) ' Display the viewing parameters. ShowViewingParameters End Sub ' ************************************************ ' Start ray tracing for this picture box. ' ************************************************ Sub RayTrace(pic As PictureBox, skip As Integer) Dim x As Integer Dim y As Integer Dim xmax As Integer Dim ymax As Integer Dim xoff As Integer Dim yoff As Integer Dim r As Integer Dim G As Integer Dim B As Integer Dim max_depth As Integer ' Get the transformed coordinates of the eye. EyeX = 0 EyeY = 0 EyeZ = EyeR ' Get the maximum depth of recursion. max_depth = CInt(DepthText.Text) xoff = pic.ScaleWidth / 2 yoff = pic.ScaleHeight / 2 xmax = pic.ScaleLeft + pic.ScaleWidth - 1 ymax = pic.ScaleTop + pic.ScaleHeight - 1 For y = pic.ScaleTop To ymax Step skip For x = pic.ScaleLeft To xmax Step skip ' Calculate the value of pixel (x, y). ' After transformation the eye is ' at (0, 0, EyeR) and the plane of ' projection lies in the X-Y plane. TraceRay max_depth, 0, 0, EyeR, _ CSng(x) - xoff, _ CSng(y) - yoff, _ -EyeR, _ r, G, B ' Draw the pixel. If skip < 2 Then pic.PSet (x, y), RGB(r, G, B) Else pic.Line (x, y)- _ Step(skip - 1, skip - 1), _ RGB(r, G, B), BF End If Next x ' Let the user see what's going on. pic.Refresh ' If the Stop button was pressed, stop. DoEvents If Not Running Then Exit Sub Next y End Sub Sub ShowViewingParameters() RText.Text = Format$(EyeR, "0") ThetaText.Text = Format$(EyeTheta, "0.0000") PhiText.Text = Format$(EyePhi, "0.0000") RText.Refresh ThetaText.Refresh PhiText.Refresh End Sub ' ************************************************ ' Do the ray tracing. ' ************************************************ Private Sub CmdGo_Click() If Running Then Running = False CmdGo.Caption = "Stopped" CmdGo.Enabled = False DoEvents Else Running = True CmdGo.Caption = "Stop" MousePointer = vbHourglass DoEvents DrawData Pict MousePointer = vbDefault CmdGo.Enabled = True CmdGo.Caption = "Go" Running = False Beep End If 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 ShowViewingParameters 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 ShowViewingParameters 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 lighting constants. LightSource.coord(1) = 100 LightSource.coord(2) = -500 LightSource.coord(3) = 1000 LightSource.coord(4) = 1 LightIar = 128 LightIag = 128 LightIab = 128 ' Initialize the eye position. EyeR = CSng(RText.Text) EyeTheta = CSng(ThetaText.Text) EyePhi = CSng(PhiText.Text) ' 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 ' ************************************************ ' Halt immediately in case we're in the middle of ' ray tracing. ' ************************************************ Private Sub Form_Unload(Cancel As Integer) End End Sub Private Sub mnuFileExit_Click() Unload Me End Sub Private Sub mnuFileSaveBitmap_Click() Dim fname As String ' Allow the user to pick a file. On Error Resume Next LoadDialog.filename = "*.BMP" LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly LoadDialog.ShowSave 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 SavePicture Pict.Image, fname End Sub ' ************************************************ ' Select this choice. ' ************************************************ Private Sub Scene_Click(index As Integer) SceneChoice = index End Sub