Option Explicit
Private Const COLOR_DEPTH_16_BIT As Long = D3DFMT_R5G6B5
Private Const COLOR_DEPTH_24_BIT As Long = D3DFMT_A8R8G8B8
Private Const COLOR_DEPTH_32_BIT As Long = D3DFMT_X8R8G8B8
Private DX As DirectX8 'The master DirectX object.
Private Direct3D As Direct3D8 'Controls all things 3D.
Private Direct3D_Device As Direct3DDevice8 'Represents the hardware rendering.
Private Direct3DX As D3DX8
Private Direct_Input As DirectInput8
Private Keyboard_Device As DirectInputDevice8
Private Keyboard_State As DIKEYBOARDSTATE
Private Fullscreen_Enabled As Boolean 'Helps determine whether it's fullscreen mode.
Private Running As Boolean 'Helps determine whether the main game loop is running.
Private Snapshot_Number As Long
Private Snapshot_Flag As Boolean
Private Sub DirectX_Initialize()
Dim Display_Mode As D3DDISPLAYMODE 'Display mode desciption.
Dim Direct3D_Window As D3DPRESENT_PARAMETERS 'Backbuffer and viewport description.
Set DX = New DirectX8 'Creates the DirectX object.
Set Direct3D = DX.Direct3DCreate() 'Creates the Direct3D object using the DirectX object.
Set Direct3DX = New D3DX8
If Fullscreen_Enabled = True Then
'Now that we are working with fullscreen mode, we must set up the
'screen resolution to switch to, rather than use the default screen
'resolution.
Display_Mode.Width = 800
Display_Mode.Height = 600
Display_Mode.Format = COLOR_DEPTH_16_BIT
Direct3D_Window.Windowed = False 'The app will be in fullscreen mode.
Direct3D_Window.BackBufferCount = 1 '1 backbuffer only
Direct3D_Window.BackBufferWidth = Display_Mode.Width 'Match the backbuffer width with the display width
Direct3D_Window.BackBufferHeight = Display_Mode.Height 'Match the backbuffer height with the display height
Direct3D_Window.hDeviceWindow = frmMain.hWnd 'Use frmMain as the device window.
Else
Direct3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Display_Mode 'Use the current display mode that you
'are already on. Incase you are confused, I'm
'talking about your current screen resolution. ;)
Direct3D_Window.Windowed = True 'The app will be in windowed mode.
End If
Direct3D_Window.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC 'Refresh when the monitor does.
Direct3D_Window.BackBufferFormat = Display_Mode.Format 'Sets the format that was retrieved into the backbuffer.
'Creates the rendering device with some useful info, along with the info
'we've already setup for Direct3D_Window.
Set Direct3D_Device = Direct3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, frmMain.hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, Direct3D_Window)
End Sub
Private Sub DirectInput_Initialize_Keyboard(Window As Form)
'Use in Form_Load to initialize DirectInput for Keyboard
Set Direct_Input = DX.DirectInputCreate
Set Keyboard_Device = Direct_Input.CreateDevice("GUID_SysKeyboard")
Keyboard_Device.SetCommonDataFormat DIFORMAT_KEYBOARD
Keyboard_Device.SetCooperativeLevel Window.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
Keyboard_Device.Acquire
Keyboard_Device.GetDeviceStateKeyboard Keyboard_State
End Sub
Private Function DirectInput_Key_State(Key_Code As Long) As Long
'Use during your game loop to check for keys pressed. DO NOT USE Keycodes.
'Only use DIK_ variables and the appropriate key.
Keyboard_Device.GetDeviceStateKeyboard Keyboard_State
DirectInput_Key_State = Keyboard_State.Key(Key_Code)
End Function
Private Sub Keyboard_Controls()
If DirectInput_Key_State(DIK_SYSRQ) <> 0 Then
If Snapshot_Flag = False Then
Snapshot_Flag = True
If Dir$(App.Path & "\Snapshots\", vbDirectory) = "" Then
MkDir App.Path & "\Snapshots\"
End If
If Dir$(App.Path & "\Snapshots\SNAP" & Format(Snapshot_Number, "####") & ".bmp") = "" Then
Snapshot App.Path & "\Snapshots\SNAP" & Format(Snapshot_Number, "####") & ".bmp"
End If
While Dir$(App.Path & "\Snapshots\SNAP" & Format(Snapshot_Number, "####") & ".bmp") <> ""
DoEvents
Snapshot_Number = Snapshot_Number + 1
Wend
End If
ElseIf DirectInput_Key_State(DIK_SYSRQ) = 0 Then
Snapshot_Flag = False
End If
End Sub
Private Sub Snapshot(ByVal File_Path As String)
Dim Surface As Direct3DSurface8
Dim SrcPalette As PALETTEENTRY
Dim SrcRect As RECT
Dim Direct3D_Display_Mode As D3DDISPLAYMODE
'get display dimensions
Direct3D_Device.GetDisplayMode Direct3D_Display_Mode
'create a surface to put front buffer on,
'GetFrontBuffer always returns D3DFMT_A8R8G8B8
Set Surface = Direct3D_Device.CreateImageSurface(Direct3D_Display_Mode.Width, Direct3D_Display_Mode.Height, D3DFMT_A8R8G8B8)
'get data from front buffer
Direct3D_Device.GetFrontBuffer Surface
'we are saving entire area of this surface
With SrcRect
.Left = 0
.Right = Direct3D_Display_Mode.Width
.Top = 0
.bottom = Direct3D_Display_Mode.Height
End With
'save this surface to a BMP file
Direct3DX.SaveSurfaceToFile File_Path, D3DXIFF_BMP, Surface, SrcPalette, SrcRect
End Sub
Private Sub Game_Loop()
Do While Running = True
Keyboard_Controls
'Clears the backbuffer.
Direct3D_Device.Clear 0, ByVal 0, D3DCLEAR_TARGET, D3DColorRGBA(0, 0, 0, 0), 1#, 0
'Rendering code goes here, but in this tutorial, it will be empty for now.
'Flips the backbuffer into the form window.
Direct3D_Device.Present ByVal 0, ByVal 0, 0, ByVal 0
If DirectInput_Key_State(DIK_ESCAPE) Then 'If the user presses the Esc key...
Shut_Down
End If
DoEvents 'Allow events to happen so the program doesn't lock up.
'Found out the hardway that it must be at the end of
'the loop if you plan to exit out of the program
'properly without using End
Loop
End Sub
Private Sub Main()
'This event will fire before the form has completely loaded
If MsgBox("Click Yes to go to full screen (Recommended)", vbQuestion Or vbYesNo, "Options") = vbYes Then Fullscreen_Enabled = True
Me.Show
frmMain.Caption = "DirectX Tutorial"
DirectX_Initialize
DirectInput_Initialize_Keyboard frmMain
Running = True 'Initializations all set. It's now ok to activate the game loop.
Game_Loop
End Sub
Private Sub Shut_Down()
Running = False 'Helps the program bail out of the game loop.
'Unload all of the DirectX objects
Set Direct_Input = Nothing
Set Direct3D_Device = Nothing
Set Direct3D = Nothing
Set DX = Nothing
Unload Me 'Unload the form
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyF1 Then
Dim StartTime: StartTime = Timer
Snapshot App.Path & "screenshot.jpg"
MsgBox Timer - StartTime
End If
End Sub
Private Sub Form_Load()
Main
End Sub
Private Sub Form_Unload(Cancel As Integer)
Shut_Down
End Sub
