fmenu.frm

游戏常见三为场景

      Width           =   2160
   End
   Begin VB.Shape shpButton 
      BackColor       =   &H00000000&
      BorderColor     =   &H00004080&
      Height          =   345
      Index           =   1
      Left            =   5160
      Shape           =   4  'Rounded Rectangle
      Top             =   2010
      Width           =   2160
   End
   Begin VB.Shape shpButton 
      BackColor       =   &H00000000&
      BorderColor     =   &H00004080&
      Height          =   345
      Index           =   0
      Left            =   5160
      Shape           =   4  'Rounded Rectangle
      Top             =   1590
      Width           =   2160
   End
   Begin VB.Shape shpButton 
      BackColor       =   &H00000000&
      BorderColor     =   &H00004080&
      Height          =   345
      Index           =   6
      Left            =   4155
      Shape           =   4  'Rounded Rectangle
      Top             =   210
      Width           =   3165
   End
End
Attribute VB_Name = "fMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' Color constants
Private Const RGBHighLight = &H80FF&       ' Highlight for mouse hover
Private Const RGBStandard = &H4080&        ' Default color
Private Const RGBSelected = &HC0C0&        ' Highlight for selected items
Private Const RGBBack = &H0&               ' Background color


' FORM_LOAD: Reset all controls to default color
Private Sub Form_Load()
        
    ' Initialize controls using hardware found
    Call InitControls
    
    ' Update controls for seleced driver
    Call UpdateControls
    
    ' Initialize control drawstate
    Call RedrawHighlights(-1)
    
End Sub

' FORM_MOUSEMOVE: Highlight handling for empty form areas
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
     Call RedrawHighlights(-1)
End Sub
' LBLBUTTON_MOUSEDOWN: Click handling for button label controls
Private Sub lblButton_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    ' Extremely highlight selected control to display click
    Me.lblButton(Index).ForeColor = RGBBack
    Me.shpButton(Index).FillColor = RGBStandard
    Me.shpButton(Index).FillStyle = 0
    
    ' React to click
    Select Case Index
         
        ' Texturemapping ?
        Case 0
            If Me.lblButton(0).Caption <> "Not supported" Then
                If Me.lblButton(0).Caption = "ENABLED" Then
                    Me.lblButton(0).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Mapping = False
                Else
                    Me.lblButton(0).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Mapping = True
                End If
            End If
            
        ' Texture perspectivic correction ?
        Case 1
            If Me.lblButton(1).Caption <> "Not supported" Then
                If Me.lblButton(1).Caption = "ENABLED" Then
                    Me.lblButton(1).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Correct = False
                Else
                    Me.lblButton(1).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Correct = True
                End If
            End If
        
        ' Transparent (color-keyed) textures ?
        Case 2
            If Me.lblButton(2).Caption <> "Not supported" Then
                If Me.lblButton(2).Caption = "ENABLED" Then
                    Me.lblButton(2).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Transparent = False
                Else
                    Me.lblButton(2).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Transparent = True
                End If
            End If
        
        ' Translucent (alpha-blended textures ?
        Case 3
            If Me.lblButton(3).Caption <> "Not supported" Then
                If Me.lblButton(3).Caption = "ENABLED" Then
                    Me.lblButton(3).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Translucent = False
                Else
                    Me.lblButton(3).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Translucent = True
                End If
            End If
        
        ' Bilinear filtering ?
        Case 4
            If Me.lblButton(4).Caption <> "Not supported" Then
                If Me.lblButton(4).Caption = "ENABLED" Then
                    Me.lblButton(4).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Filtering = False
                Else
                    Me.lblButton(4).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Filtering = True
                End If
            End If
        
        ' Phong ?
        Case 5
            If Me.lblButton(5).Caption <> "Not supported" Then
                If Me.lblButton(5).Caption = "ENABLED" Then
                    Me.lblButton(5).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Phong = False
                Else
                    Me.lblButton(5).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Phong = True
                End If
            End If
        
        ' Specular highlights ?
        Case 13
            If Me.lblButton(13).Caption <> "Not supported" Then
                If Me.lblButton(13).Caption = "ENABLED" Then
                    Me.lblButton(13).Caption = "DISABLED"
                    G_dUser.DisplayOptions.Specular = False
                Else
                    Me.lblButton(13).Caption = "ENABLED"
                    G_dUser.DisplayOptions.Specular = True
                End If
            End If
        
        
        ' Select RGB driver
        Case 6
            If G_dDXDriverSoft.Found Then
                G_dDXSelectedDriver = G_dDXDriverSoft
                UpdateControls
            End If
            
        ' Select HAL driver
        Case 7
            If G_dDXDriverHard.Found Then
                G_dDXSelectedDriver = G_dDXDriverHard
                UpdateControls
            End If
            
        ' Select 3DFX driver
        Case 14
            If G_dDXDriverPlus.Found Then
                G_dDXSelectedDriver = G_dDXDriverPlus
                UpdateControls
            End If
        
        ' Larger
        Case 8
            If Len(Me.lblButton(10).Caption) < 20 Then
                Me.lblButton(10).Caption = Me.lblButton(10).Caption & "|"
                G_dUser.DisplaySize = (20 - Len(Me.lblButton(10).Caption)) * 10
            End If
            
        ' Smaller
        Case 9
            If Len(Me.lblButton(11).Caption) > 1 Then
                Me.lblButton(10).Caption = Left(Me.lblButton(10).Caption, Len(Me.lblButton(10).Caption) - 1)
                G_dUser.DisplaySize = (20 - Len(Me.lblButton(10).Caption)) * 10
            End If
        
        ' Quit
        Case 11
            Me.Hide
            On Error Resume Next
            Shell App.Path + "\nls.exe", vbNormalFocus
            Unload Me
            End
            
        ' Start
        Case 12
            Unload Me
            
        ' Info
        Case 15
            
            Me.Hide
            fMsg.Hide
            fMsg.lblTitle = "EYE3D (C) 1999 by Nonlinear Solutions"
            fMsg.lblText = "Use arrow keys to move, mouse to look, ESC to exit." + vbCrLf + vbCrLf + "Known bugs: On 3DFX cards, texture animations don't work. On some 2D cards, translucency will be listed available, but translucent surfaces will not be visible." + vbCrLf + vbCrLf + "Visit us at www.dige.com/nls"
            fMsg.Show 1
            Me.Show 1
        
    End Select
    
End Sub
' LBLBUTTON_MOUSEMOVE: Highlight handling for button label controls
Private Sub lblButton_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 0 Then Call RedrawHighlights(Index)
End Sub
' LBLBUTTON_MOUSEUP: Highlight handling for button label control
Private Sub lblButton_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call RedrawHighlights(-1)
End Sub
' LBLCAPTION_MOUSEMOVE: Highlight handling for caption controls
Private Sub lblCaption_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call RedrawHighlights(-1)
End Sub

' REDRAWHIGHLIGHTS: Redraws highlights for controls
Private Sub RedrawHighlights(nControlIndex As Integer)

    ' Setup local variables ...
        Dim nRunControls As Integer ' Variable to run through controls
        
    ' Redraw highlights ...
        
        For nRunControls = 0 To 15
            If nRunControls = 6 Then
                Me.lblButton(nRunControls).ForeColor = IIf(G_dDXSelectedDriver.DriverType = EDXDTSoft, RGBSelected, IIf(nControlIndex = 6, RGBHighLight, RGBStandard))
            ElseIf nRunControls = 7 Then
                Me.lblButton(nRunControls).ForeColor = IIf(G_dDXSelectedDriver.DriverType = EDXDTHard, RGBSelected, IIf(nControlIndex = 7, RGBHighLight, RGBStandard))
            ElseIf nRunControls = 14 Then
                Me.lblButton(nRunControls).ForeColor = IIf(G_dDXSelectedDriver.DriverType = EDXDTPlus, RGBSelected, IIf(nControlIndex = 14, RGBHighLight, RGBStandard))
            Else
                Me.lblButton(nRunControls).ForeColor = RGBStandard
            End If
            Me.shpButton(nRunControls).FillStyle = 1
            Me.shpButton(nRunControls).BorderColor = IIf(nRunControls = nControlIndex, RGBHighLight, RGBStandard)
        Next
        
        For nRunControls = 0 To Me.lneCaption.Count - 1
            Me.lneCaption(nRunControls).BorderColor = RGBStandard
        Next
        
        For nRunControls = 0 To Me.lblCaption.Count - 1
            Me.lblCaption(nRunControls).ForeColor = RGBStandard
        Next
        
End Sub

' UPDATECONTROLS: Refill control captions with values based on driver selection
Private Sub UpdateControls()

    
    ' THE FOLLOWING FEATURES ARE DRIVER-DEPENDEND AND ARE THEREFORE CHECKED AGAINST THE DRIVER DESCRIPTION ...
    
        ' Get settings from driver currently selected
        With G_dDXSelectedDriver.D3DDriver
            
            ' Bilinear filtering ?
            If (.DEVDESC.dpcTriCaps.dwTextureFilterCaps And D3DPTFILTERCAPS_LINEAR) = D3DPTFILTERCAPS_LINEAR Then
                If G_dUser.DisplayOptions.Filtering Then
                    Me.lblButton(4).Caption = "ENABLED"
                Else
                    Me.lblButton(4).Caption = "DISABLED"
                End If
            Else
                Me.lblButton(4).Caption = "Not supported"
                G_dUser.DisplayOptions.Filtering = False
            End If
            
            ' Transparent (color-keyed) textures ?
            If (.DEVDESC.dpcTriCaps.dwTextureCaps And D3DPTEXTURECAPS_TRANSPARENCY) = D3DPTEXTURECAPS_TRANSPARENCY Then
                If G_dUser.DisplayOptions.Transparent Then
                    Me.lblButton(2).Caption = "ENABLED"
                Else
                    Me.lblButton(2).Caption = "DISABLED"
                End If
            Else
                Me.lblButton(2).Caption = "Not supported"
                G_dUser.DisplayOptions.Transparent = False
            End If
            
            ' Translucent (alpha-blended) textures ?
            If ((.DEVDESC.dpcTriCaps.dwSrcBlendCaps And D3DPBLENDCAPS_BOTHSRCALPHA) = D3DPBLENDCAPS_BOTHSRCALPHA) Then
                If G_dUser.DisplayOptions.Translucent Then
                    Me.lblButton(3).Caption = "ENABLED"
                Else
                    Me.lblButton(3).Caption = "DISABLED"
                End If
            Else
                Me.lblButton(3).Caption = "Not supported"
                G_dUser.DisplayOptions.Translucent = False
            End If
            
            ' Phong shading
            If ((.DEVDESC.dpcTriCaps.dwShadeCaps And D3DPSHADECAPS_COLORPHONGRGB) = D3DPSHADECAPS_COLORPHONGRGB) Then
                If G_dUser.DisplayOptions.Phong Then
                    Me.lblButton(5).Caption = "ENABLED"
                Else
                    Me.lblButton(5).Caption = "DISABLED"
                End If
            Else
                Me.lblButton(5).Caption = "Not supported"
                G_dUser.DisplayOptions.Phong = False
            End If
            
            ' Specular lighting ?
            If (.DEVDESC.dpcTriCaps.dwShadeCaps And D3DPSHADECAPS_SPECULARGOURAUDRGB) = D3DPSHADECAPS_SPECULARGOURAUDRGB Then
                If G_dUser.DisplayOptions.Specular Then
                    Me.lblButton(13).Caption = "ENABLED"
                Else
                    Me.lblButton(13).Caption = "DISABLED"
                End If
            Else
                Me.lblButton(13).Caption = "Not supported"
                G_dUser.DisplayOptions.Specular = False
            End If
        
        End With
    
    ' THE FOLLOWING FEATURES SEEM TO WORK ON ANY CARD ...
    
        ' Texturemapping ?
        If G_dUser.DisplayOptions.Mapping Then
            Me.lblButton(0).Caption = "ENABLED"
        Else
            Me.lblButton(0).Caption = "DISABLED"
        End If
        
        ' Perspectivic correction ?
        If G_dUser.DisplayOptions.Correct Then
            Me.lblButton(1).Caption = "ENABLED"
        Else
            Me.lblButton(1).Caption = "DISABLED"
        End If
    
    ' MISCELLANEOUS FEATURES ...
    
        ' Screensize
        Me.lblButton(10).Caption = String(20 - G_dUser.DisplaySize \ 20, "|")
    
End Sub

' INITCONTROLS: Initialized controls based on found hardware, write stats
Private Sub InitControls()
    
    ' STATS ...

        Me.lblStats.Caption = "Avg. frametime: " & IIf(G_dUser.Stats.Frametime < 1, "n/a", Format(G_dUser.Stats.Frametime, "0.0") & "fps")
        
    ' HAL driver...
        If G_dDXDriverHard.Found Then
            Me.lblButton(7).Caption = "HAL optimized hardware device"
        Else
            Me.lblButton(7).Caption = "No HAL device driver detected"
        End If
        
    ' Hardware accellerator...
        If G_dDXDriverPlus.Found Then
            Me.lblButton(14).Caption = Left(G_dDXDriverPlus.Name, 30)
        Else
            Me.lblButton(14).Caption = "No add-on board detected"
        End If
        
End Sub