VERSION 5.00
Begin VB.Form frmMain
BackColor = &H00000000&
Caption = "$$BLANK$$"
ClientHeight = 5505
ClientLeft = 165
ClientTop = 855
ClientWidth = 6225
BeginProperty Font
Name = "Arial"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 367
ScaleMode = 3 'Pixel
ScaleWidth = 415
StartUpPosition = 3 'Windows Default
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuGoStop
Caption = "Go/Stop"
Shortcut = {F3}
End
Begin VB.Menu mnuSingleStep
Caption = "Single Step"
Shortcut = {F4}
End
Begin VB.Menu mnuFileLine1
Caption = "-"
End
Begin VB.Menu mnuChangeDevice
Caption = "Change Device..."
Shortcut = {F2}
End
Begin VB.Menu mnuFileLine2
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "E&xit ESC"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Application Title: $$BLANK$$
' Developer:
'
'
'
' File: frmMain.frm
' Content: A minimal implementation of the VB DX8.1 SDK framework.
' Well you could make it smaller, but it is pretty minimal!
'
' This project includes portions of the Microsoft DirectX 8.1
' SDK. Copyright (c) 1999-2001 Microsoft Corporation. All rights
' reserved. Portions Copyright (C) 2001 Rich Thomson. All rights
' reserved. Content is not
' to be duplicated without permission from the authors. Adaptation
' to Visual Basic by Eric DeBrosse
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
'-----------------------------------------------------------------------------
' Variables
'-----------------------------------------------------------------------------
Dim m_bIsInit As Boolean 'indicates d3d has been initialized
Dim m_bIsMinimized As Boolean 'indicates display window is minimized
Dim m_bIsRunning As Boolean 'indicates animation is running
Dim m_fTime As Single
Dim m_fLastTime As Single
Dim m_fFPS As Single
Dim m_lFrameCount As Long
'holds width and height of frame buffer
Dim m_lBufWidth As Long
Dim m_lBufHeight As Long
Dim m_DispFormat As CONST_D3DFORMAT
Dim m_oStatusFont As D3DXFont
Dim m_FontRect As RECT
Dim m_sStatusText As String
Dim m_sStatusHold As String
'-----------------------------------------------------------------------------
' Name: GetCurrentDeviceName
' Desc: Returns a string that describes the current D3D device.
'-----------------------------------------------------------------------------
Private Function GetCurrentDeviceName() As String
Dim sDescription As String
sDescription = StrConv(g_Adapters(g_lCurrentAdapter).d3dai.Description, vbUnicode)
sDescription = Replace(sDescription, Chr$(0), "")
'do we have a description?
If sDescription = "" Then
GetCurrentDeviceName = "Unknown Device"
Else
'return device description
GetCurrentDeviceName = sDescription
End If
End Function
'-----------------------------------------------------------------------------
' Name: Form_Load()
' Desc: Application starting point and main processing loop.
'-----------------------------------------------------------------------------
Private Sub Form_Load()
On Error Resume Next
'set defaults
'force form to show now
Me.Show
DoEvents
'Initialize D3D
'Note: D3DUtil_Init will attempt to use D3D Hardware acceleration.
'If not available, it will attempt to use the Software Reference Rasterizer.
'If everything fails, it will display a message box indicating so.
m_bIsInit = D3DUtil_Init(Me.hwnd, True, 0, 0, D3DDEVTYPE_HAL, Me)
If Not (m_bIsInit) Then End
'sets the state for the objects and the current D3D device
InitDeviceObjects
RestoreDeviceObjects
'start application timer
DXUtil_Timer TIMER_start
m_bIsRunning = True
'run the simulation forever
'see Form_Keydown for exit processing
Do While True
'increment the simulation
FrameMove
'render one frame of the simulation
If Render() = True Then
'present the image to the screen
g_dev.Present ByVal 0&, ByVal 0&, g_focushwnd, ByVal 0&
End If
'allow for events to get processed
DoEvents
Loop
End Sub
'-----------------------------------------------------------------------------
' Name: Form_KeyDown()
' Desc: Process key messages for exit and change device
'-----------------------------------------------------------------------------
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim hr As Long
Select Case KeyCode
Case vbKeyEscape
'escape to exit
Unload Me
Case vbKeyF2
'Pause the timer
DXUtil_Timer TIMER_STOP
'Bring up the device selection dialog
'we pass in the form so the selection process
'can make calls into InitDeviceObjects
'and RestoreDeviceObjects
frmSelectDevice.SelectDevice Me
'Restart the timer
DXUtil_Timer TIMER_start
Case vbKeyReturn
'Check for Alt-Enter, if not pressed exit
If Shift <> 4 Then Exit Sub
'we must invalidate objects before a reset
InvalidateDeviceObjects
'If we are windowed go fullscreen
'If we are fullscreen returned to windowed
If g_d3dpp.Windowed Then
hr = D3DUtil_ResetFullscreen
Else
hr = D3DUtil_ResetWindowed
End If
'Call Restore after every mode change
'because calling reset looses states that need to
'be reinitialized
If hr = D3D_OK Then
RestoreDeviceObjects
End If
End Select
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Resize()
' Desc: Handles resizing of the D3D backbuffer.
'-----------------------------------------------------------------------------
Private Sub Form_Resize()
'If D3D is not initialized then exit
If Not m_bIsInit Then Exit Sub
'If we are in a minimized state stop the timer and exit
If Me.WindowState = vbMinimized Then
DXUtil_Timer TIMER_STOP
m_bIsMinimized = True
Exit Sub
'If we just went from a minimized state to maximized
'restart the timer
Else
If m_bIsMinimized = True Then
If m_bIsRunning = True Then
DXUtil_Timer TIMER_start
End If
m_bIsMinimized = False
End If
End If
'dont let the window get too small
If Me.ScaleWidth < 10 Then
Me.width = Screen.TwipsPerPixelX * 10
Exit Sub
End If
If Me.ScaleHeight < 10 Then
Me.height = Screen.TwipsPerPixelY * 10
Exit Sub
End If
'fonts must be destroyed before a reset
InvalidateDeviceObjects
'reset and resize our D3D backbuffer to the size of the window
D3DUtil_ResizeWindowed Me.hwnd
'All states get lost after a reset, so we need to re-initialize
RestoreDeviceObjects
End Sub
'-----------------------------------------------------------------------------
' Name: Form_Unload()
' Desc: Destroys all objects that were in use by application.
'-----------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
'destroy all objects
InvalidateDeviceObjects
DeleteDeviceObjects
'destroy d3d stuff
D3DUtil_Destory
'end program
End
End Sub
'-----------------------------------------------------------------------------
' Name: SetStates()
' Desc: We set the renderstates appropriate for the mesh.
'-----------------------------------------------------------------------------
Private Sub SetStates()
On Error Resume Next
'setup device states to something reasonable
With g_dev
.SetRenderState D3DRS_CLIPPLANEENABLE, 0
.SetRenderState D3DRS_CULLMODE, D3DCULL_CCW
.SetRenderState D3DRS_FILLMODE, D3DFILL_SOLID
.SetRenderState D3DRS_SHADEMODE, D3DSHADE_GOURAUD
.SetRenderState D3DRS_CLIPPING, 1
.SetRenderState D3DRS_LIGHTING, 0
.SetRenderState D3DRS_LOCALVIEWER, 0
.SetRenderState D3DRS_AMBIENT, &HFFFFFFFF
.SetRenderState D3DRS_SPECULARENABLE, 0
.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
.SetRenderState D3DRS_ZWRITEENABLE, 1
.SetRenderState D3DRS_ZFUNC, D3DCMP_LESS
.SetRenderState D3DRS_ZBIAS, 0
.SetRenderState D3DRS_STENCILENABLE, 0
.SetRenderState D3DRS_ALPHABLENDENABLE, 0
.SetRenderState D3DRS_ALPHATESTENABLE, 0
.SetRenderState D3DRS_DITHERENABLE, 1
.SetRenderState D3DRS_NORMALIZENORMALS, 0
.SetRenderState D3DRS_COLORVERTEX, 0
.SetRenderState D3DRS_AMBIENTMATERIALSOURCE, D3DMCS_MATERIAL
.SetRenderState D3DRS_DIFFUSEMATERIALSOURCE, D3DMCS_MATERIAL
.SetRenderState D3DRS_SPECULARMATERIALSOURCE, D3DMCS_MATERIAL
.SetRenderState D3DRS_EMISSIVEMATERIALSOURCE, D3DMCS_MATERIAL
End With
End Sub
'-----------------------------------------------------------------------------
' Name: UpdateStatusText()
' Desc:
'-----------------------------------------------------------------------------
Private Sub UpdateStatusText()
Dim DevString As String
Dim FormatString As String
'get device string
If g_devType = D3DDEVTYPE_REF Then
'reference (software only) device
DevString = "REF: "
Else
'VB SDK framework does not detect and/or enable pure devices
If g_behaviorflags Or D3DCREATE_HARDWARE_VERTEXPROCESSING = D3DCREATE_HARDWARE_VERTEXPROCESSING Then
DevString = "HAL (hw vp): "
Else
'software vertex processing
DevString = "HAL (sw vp): "
End If
End If
'get color depth
If m_DispFormat = D3DFMT_R5G6B5 Then
FormatString = "x16"
Else
FormatString = "x32"
End If
'VB SDK framework always picks D16 depth format
m_sStatusHold = " fps (" & m_lBufWidth & "x" & m_lBufHeight & FormatString & ") (D16)" & _
vbCrLf & DevString & GetCurrentDeviceName
End Sub
'-----------------------------------------------------------------------------
' Name: CreateFonts()
' Desc: Create the D3DXFont for the status text.
'-----------------------------------------------------------------------------
Private Sub CreateFonts()
Dim oTempFont As IFont
'create status font
Set oTempFont = frmMain.Font
Set m_oStatusFont = Nothing
Set m_oStatusFont = g_d3dx.CreateFont(g_dev, oTempFont.hFont)
Set oTempFont = Nothing
End Sub
'-----------------------------------------------------------------------------
' Name: FrameMove()
' Desc: Called once per frame, the call is the entry point for animating
' the scene.
'-----------------------------------------------------------------------------
Private Sub FrameMove()
m_fTime = DXUtil_Timer(TIMER_GETABSOLUTETIME)
End Sub
'-----------------------------------------------------------------------------
' Name: Render()
' Desc: Called once per frame, the call is the entry point for 3d
' rendering. This function sets up render states, clears the
' viewport, and renders the scene.
'-----------------------------------------------------------------------------
Private Function Render() As Boolean
On Error Resume Next
If g_dev Is Nothing Then GoTo errOut
Select Case g_dev.TestCooperativeLevel
Case D3DERR_DEVICENOTRESET
'try to reset device
g_dev.Reset g_d3dpp
Exit Function
Case Is <> D3D_OK
'dont bother rendering if we are not ready yet
Exit Function
End Select
On Error GoTo errOut
'begin scene
g_dev.BeginScene
'clear the target and zbuffer
g_dev.Clear 0&, ByVal 0&, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, 0&, 1!, 0&
'render some stuff here
'show frame rate and device statistics
m_lFrameCount = m_lFrameCount + 1&
'update the scene stats once per second
If m_fTime - m_fLastTime > 1! Then
m_fFPS = m_lFrameCount / (m_fTime - m_fLastTime)
m_fLastTime = m_fTime
m_lFrameCount = 0&
End If
m_sStatusText = format(m_fFPS, "###,##0.00") & m_sStatusHold
'draw status text
m_oStatusFont.Begin
m_oStatusFont.DrawTextW m_sStatusText, -1&, m_FontRect, DT_CALCRECT, 0&
m_oStatusFont.DrawTextW m_sStatusText, -1&, m_FontRect, DT_NOCLIP Or DT_LEFT, &HFF00FFFF
m_oStatusFont.End
'end scene
g_dev.EndScene
Render = True
Exit Function
errOut:
Render = False
End Function
'-----------------------------------------------------------------------------
' Name: InitDeviceObjects()
' Desc: This creates all device-dependant managed objects, such as managed
' textures and managed vertex buffers.
'-----------------------------------------------------------------------------
Public Sub InitDeviceObjects()
'
End Sub
'-----------------------------------------------------------------------------
' Name: RestoreDeviceObjects()
' Desc: Restore device-memory objects and state after a device is created or
' resized.
'-----------------------------------------------------------------------------
Public Sub RestoreDeviceObjects()
Dim DispMode As D3DDISPLAYMODE
'get current display settings
g_dev.GetDisplayMode DispMode
'cache size of frame buffer
If g_d3dpp.Windowed Then
m_lBufWidth = g_lWindowWidth
m_lBufHeight = g_lWindowHeight
Else
m_lBufWidth = DispMode.width
m_lBufHeight = DispMode.height
End If
'cache display format for status text
m_DispFormat = DispMode.format
'initialize status text object
CreateFonts
'build string for status text
UpdateStatusText
'set render states that we need
SetStates
End Sub
'-----------------------------------------------------------------------------
' Name: InvalidateDeviceObjects()
' Desc: Called when the device-dependant objects are about to be lost.
'-----------------------------------------------------------------------------
Public Sub InvalidateDeviceObjects()
Set m_oStatusFont = Nothing
End Sub
'-----------------------------------------------------------------------------
' Name: DeleteDeviceObjects()
' Desc: Called when the app is exiting, or the device is being changed,
' this function deletes any device dependent objects.
'-----------------------------------------------------------------------------
Public Sub DeleteDeviceObjects()
'device objects are no longer initialized
m_bIsInit = False
End Sub
'-----------------------------------------------------------------------------
' Name: VerifyDevice()
' Desc: Called during device intialization, this code checks the device
' for some minimum set of capabilities.
'-----------------------------------------------------------------------------
Public Function VerifyDevice(ByVal usageflags As Long, ByVal format As CONST_D3DFORMAT) As Boolean
VerifyDevice = True
End Function
'-----------------------------------------------------------------------------
' Name: mnuChangeDevice_Click()
' Desc:
'-----------------------------------------------------------------------------
Private Sub mnuChangeDevice_Click()
Form_KeyDown vbKeyF2, 0
End Sub
'-----------------------------------------------------------------------------
' Name: mnuExit_Click()
' Desc:
'-----------------------------------------------------------------------------
Private Sub mnuExit_Click()
Unload Me
End Sub
'-----------------------------------------------------------------------------
' Name: mnuGoStop_Click()
' Desc:
'-----------------------------------------------------------------------------
Private Sub mnuGoStop_Click()
If m_bIsRunning = True Then
DXUtil_Timer TIMER_STOP
m_bIsRunning = False
Else
DXUtil_Timer TIMER_start
m_bIsRunning = True
End If
End Sub
'-----------------------------------------------------------------------------
' Name: mnuSingleStep_Click()
' Desc:
'-----------------------------------------------------------------------------
Private Sub mnuSingleStep_Click()
If m_bIsRunning = True Then
DXUtil_Timer TIMER_STOP
m_bIsRunning = False
End If
'manually advance time
m_fTime = m_fTime + 0.1
End Sub