frmmain.frm

一个游戏的原代码

      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Label Label10 
      Alignment       =   2  'Center
      Appearance      =   0  'Flat
      BackColor       =   &H00E0E0E0&
      BorderStyle     =   1  'Fixed Single
      Caption         =   "No file loaded"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000008&
      Height          =   255
      Left            =   9360
      TabIndex        =   36
      Top             =   3240
      Width           =   2055
   End
   Begin VB.Menu file 
      Caption         =   "File"
      Begin VB.Menu mnuLoadMD3Player 
         Caption         =   "Load MD3 player(人物)"
      End
      Begin VB.Menu mnuLoadMD3Weapon 
         Caption         =   "Load MD3 weapon(武器)"
      End
      Begin VB.Menu step1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuLoadMD2Player 
         Caption         =   "Load MD2 player(人物)"
      End
      Begin VB.Menu mnuLoadMD2Weapon 
         Caption         =   "Load MD2 weapon(武器)"
      End
      Begin VB.Menu step2 
         Caption         =   "-"
      End
      Begin VB.Menu exit 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu opt 
      Caption         =   "Options"
      Begin VB.Menu mnuTextured 
         Caption         =   "Textured(贴图)"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuGouraud 
         Caption         =   "Gouraud shading(光滑渲染)"
         Checked         =   -1  'True
      End
      Begin VB.Menu mnuWireframe 
         Caption         =   "Wireframe(线框)"
      End
   End
   Begin VB.Menu info 
      Caption         =   "Info"
      Begin VB.Menu about 
         Caption         =   "About"
      End
      Begin VB.Menu step3 
         Caption         =   "-"
      End
      Begin VB.Menu hp 
         Caption         =   "Visit homepage"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'QuakeView - MD2/MD3 model viewer
Option Explicit

Private lRunning As Boolean
Private MD2Model As New Cls_MD2
Private MD2Weapon As New Cls_MD2

Private MD3Model As New Cls_MD3Loader


Private plane As D3DPLANE
Private ReflectInMirror As D3DMATRIX
'Die Ecken des Spiegels ermitteln
Private A As D3DVECTOR
Private B As D3DVECTOR
Private c As D3DVECTOR
Private d As D3DVECTOR


Private Function InitD3D()
Set Direct3D = DirectX.Direct3DCreate()
If Direct3D Is Nothing Then Debug.Print "Direct3D konnte nicht erstellt werden"

Direct3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, DisplaySettings
D3DWindow.Windowed = 1
D3DWindow.BackBufferFormat = DisplaySettings.Format
D3DWindow.BackBufferWidth = Picture1.ScaleWidth
D3DWindow.BackBufferHeight = Picture1.ScaleHeight

D3DWindow.hDeviceWindow = Picture1.hwnd
D3DWindow.SwapEffect = D3DSWAPEFFECT_FLIP
D3DWindow.BackBufferCount = 1
D3DWindow.EnableAutoDepthStencil = 1
D3DWindow.AutoDepthStencilFormat = CheckZBuffer(DisplaySettings)

Set D3Ddevice = Direct3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, D3DWindow.hDeviceWindow, CheckHardwareTL(), D3DWindow)
If D3Ddevice Is Nothing Then Debug.Print "Direct3D-Device konnte nicht erstellt werden"
Me.Show

'initialize MD2 normals table and material
InitLightNormals

'Licht aktivieren
D3Ddevice.SetRenderState D3DRS_LIGHTING, 1
'Wir benutzen nur Ambient-Licht
D3Ddevice.SetRenderState D3DRS_AMBIENT, D3DColorARGB(96, 96, 96, 96)


D3Ddevice.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID
D3Ddevice.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
D3Ddevice.SetTextureStageState 0, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
D3Ddevice.SetTextureStageState 0, D3DTSS_MINFILTER, D3DTEXF_LINEAR
D3Ddevice.SetTextureStageState 0, D3DTSS_MIPFILTER, D3DTEXF_LINEAR

D3DXMatrixIdentity matWorld
D3Ddevice.SetTransform D3DTS_WORLD, matWorld

D3DXMatrixLookAtLH matView, MakeVector(0, 20, 100), MakeVector(0, 0, 0), MakeVector(0, 1, 0)
D3Ddevice.SetTransform D3DTS_VIEW, matView

D3DXMatrixPerspectiveFovLH matProj, PI / 4, 1, 0.1, 1000
D3Ddevice.SetTransform D3DTS_PROJECTION, matProj

modCam.InitCam

lRunning = True

Set ScreenShotSurface = D3Ddevice.CreateImageSurface(DisplaySettings.Width, DisplaySettings.Height, D3DFMT_A8R8G8B8)

Set DXfontDesc = fnt
Set DXfont = CreateFont("arial", 9, False, False, True)

modFloor.CreateFloor 0, App.path & "\rustyfloor.bmp"
FPS_timefactor = 1

Do
D3Ddevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF000000, 1#, 0
D3Ddevice.BeginScene

modCam.Movement
modCam.SetCam

'Render MD2 model (character)
If MD2Model.Loaded Or MD3Model.bLoaded Then
    'Model rendern
    D3Ddevice.SetRenderState D3DRS_CULLMODE, D3DCULL_CCW
    If MD2Model.Loaded Then
        MD2Model.Render MD2Weapon
    Else
        MD3Model.Render matWorld, True
    End If
    
    If Check4.Value = 1 And Check5.Value = 1 Then
        A = FVertex(1).pos
        B = FVertex(0).pos
        c = FVertex(3).pos
        d = FVertex(2).pos
    
        D3DXPlaneFromPoints plane, A, B, c
        D3DXMatrixReflect ReflectInMirror, plane
        'Clip-Planes berechnen
        D3DXPlaneFromPoints plane, B, A, player.vPLookAt
        D3Ddevice.SetClipPlane 0, plane
        D3DXPlaneFromPoints plane, d, B, player.vPLookAt
        D3Ddevice.SetClipPlane 1, plane
        D3DXPlaneFromPoints plane, c, d, player.vPLookAt
        D3Ddevice.SetClipPlane 2, plane
        D3DXPlaneFromPoints plane, A, c, player.vPLookAt
        D3Ddevice.SetClipPlane 3, plane
    
        'Clip-Planes aktivieren
        D3Ddevice.SetRenderState D3DRS_CLIPPLANEENABLE, D3DCLIPPLANE0 Or D3DCLIPPLANE1 Or _
                                                        D3DCLIPPLANE2 Or D3DCLIPPLANE3
        'Anderen Cullmode setzen
        D3Ddevice.SetRenderState D3DRS_CULLMODE, D3DCULL_CW
        If MD2Model.Loaded Then
            D3Ddevice.SetTransform D3DTS_WORLD, ReflectInMirror 'Reflektierte Matrix setzen
            MD2Model.Render WeaponModel:=MD2Weapon, NoUpdate:=True 'Reflektion rendern (ohne Ver鋘derung/Neuberechnung der Geometrie)
            Label1.Caption = MD2Model.GetFrameName(MD2Model.ActualFrameID)
        Else
            MD3Model.Render ReflectInMirror, False
        End If
        'Standard-Transformation setzen und Clip-Planes deaktivieren
        D3Ddevice.SetTransform D3DTS_WORLD, matWorld
        D3Ddevice.SetRenderState D3DRS_CLIPPLANEENABLE, &H0
    End If
End If

If Check4.Value = 1 Then
    If mnuWireframe.Checked Then
        D3Ddevice.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID
    End If
    modFloor.RenderFloor MD2Model.Texture
    If mnuWireframe.Checked Then
        D3Ddevice.SetRenderState D3DRS_FILLMODE, D3DFILL_WIREFRAME
    End If
End If


TextBox "FPS: " & FPS_Current, DXfont, 10, 10, 200, 32, &HFFFFFFFF

D3Ddevice.EndScene
D3Ddevice.Present ByVal 0, ByVal 0, 0, ByVal 0

FPS_timefactor = QPTimer - FPS_tLastFrame
FPS_tLastFrame = QPTimer

FPS_Counter = FPS_Counter + 1
If QPTimer - FPS_tLastFPSdisplay >= 1 Then
    FPS_Current = FPS_Counter / (QPTimer - FPS_tLastFPSdisplay)
    FPS_Counter = 0
    FPS_tLastFPSdisplay = QPTimer
End If

If CheckKey(DIK_ESCAPE) = MVB_DOWN Then
lRunning = False
End If
DoEvents
Loop While lRunning

Set D3Ddevice = Nothing
Set Direct3D = Nothing
Set DirectX = Nothing

Unload Me
End
End Function

Private Function CheckZBuffer(Mode As D3DDISPLAYMODE) As Long
If Direct3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Mode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D16) = D3D_OK Then
CheckZBuffer = D3DFMT_D16
End If
        
If Direct3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Mode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D16_LOCKABLE) = D3D_OK Then
CheckZBuffer = D3DFMT_D16_LOCKABLE
End If
        
If Direct3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Mode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D24S8) = D3D_OK Then
CheckZBuffer = D3DFMT_D24S8
End If
        
If Direct3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Mode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D24X4S4) = D3D_OK Then
CheckZBuffer = D3DFMT_D24X4S4
End If
        
If Direct3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Mode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D24X8) = D3D_OK Then
CheckZBuffer = D3DFMT_D24X8
End If
        
If Direct3D.CheckDeviceFormat(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Mode.Format, D3DUSAGE_DEPTHSTENCIL, D3DRTYPE_SURFACE, D3DFMT_D32) = D3D_OK Then
CheckZBuffer = D3DFMT_D32
End If
End Function

Private Function CheckHardwareTL() As Long
Dim DevCaps As D3DCAPS8
Direct3D.GetDeviceCaps D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, DevCaps

If (DevCaps.DevCaps And D3DDEVCAPS_HWTRANSFORMANDLIGHT) Then
CheckHardwareTL = D3DCREATE_HARDWARE_VERTEXPROCESSING
Else
CheckHardwareTL = D3DCREATE_SOFTWARE_VERTEXPROCESSING
End If
End Function

Private Sub about_Click()
frmAbout.Show OwnerForm:=Me
End Sub

Private Sub canim_Click()
MD2Model.AnimType = 1
MD2Weapon.AnimType = 1
End Sub

Private Sub Check1_Click()
Dim lastFrameName As String
If Check1.Value = 1 Or (Check3.Value = 0 And Check1.Value = 0) Then
List1.Clear
For i = 0 To MD2Model.NumFrames
If Not lastFrameName = Mid(MD2Model.GetFrameName(i), 1, InStrNum(MD2Model.GetFrameName(i)) - 1) Then
lastFrameName = Mid(MD2Model.GetFrameName(i), 1, InStrNum(MD2Model.GetFrameName(i)) - 1)
List1.AddItem Mid(MD2Model.GetFrameName(i), 1, InStrNum(MD2Model.GetFrameName(i)) - 1)
End If
Next i
List1.ListIndex = 0
Check3.Value = 0
Check2.Value = 1
Check1.Value = 1
End If
End Sub

Private Sub Check3_Click()
If Check3.Value = 1 Or (Check1.Value = 0 And Check3.Value = 0) Then
    List1.Clear
    For i = 0 To MD2Model.NumFrames
        List1.AddItem MD2Model.GetFrameName(i)
    Next i
    List1.ListIndex = 0
    Check1.Value = 0
    Check2.Value = 0
    Check3.Value = 1
End If
End Sub

Private Sub Check4_Click()
If Check4.Value = 1 Then
    Check5.Enabled = True
Else
    Check5.Enabled = False
End If
End Sub

Private Sub Check6_Click()
MD3Model.bDbgRenderHitBoxes = Check6.Value
End Sub

Private Sub Check7_Click()
MD3Model.bDbgRenderBoundingBox = Check7.Value
End Sub

Private Sub chkSmoothBone_Click()
MD3Model.bSmoothBoneAnim = chkSmoothBone.Value
End Sub

Private Sub cmbLower_Click()
Select Case cmbLower.List(cmbLower.ListIndex)
 Case "Crouch-Walk"
  MD3Model.SetLowerAni = LEGS_WALKCR
 Case "Walk"
  MD3Model.SetLowerAni = LEGS_WALK
 Case "Run"
  MD3Model.SetLowerAni = LEGS_RUN
 Case "Back"
  MD3Model.SetLowerAni = LEGS_BACK