Visual Basic Game Programming for Teens/VBGPFT.cdr/sources/chapter04/DrawTile/Form1.frm

Visual Basic Form | 2004-11-06 | 5.8 KB | 182 lines

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  'Windows Default
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'---------------------------------------------------------------
' Visual Basic Game Programming for Teens
' Chapter 4 - DrawTile program
'---------------------------------------------------------------
'make sure every variable is declared
Option Explicit
'make all arrays start with 0 instead of 1
Option Base 0
'customize the program here
Const SCREENWIDTH As Long = 800
Const SCREENHEIGHT As Long = 600
Const FULLSCREEN As Boolean = False
Const C_BLACK As Long = &H0
Const C_RED As Long = &HFF0000
'the DirectX objects
Dim dx As DirectX8
Dim d3d As Direct3D8
Dim d3dx As New D3DX8
Dim dispmode As D3DDISPLAYMODE
Dim d3dpp As D3DPRESENT_PARAMETERS
Dim d3ddev As Direct3DDevice8
'some surfaces
Dim backbuffer As Direct3DSurface8
Dim castle As Direct3DSurface8
Private Sub Form_Load()
    'set up the main form
    Form1.Caption = "DrawTile"
    Form1.ScaleMode = 3
    Form1.width = Screen.TwipsPerPixelX * (SCREENWIDTH + 12)
    Form1.height = Screen.TwipsPerPixelY * (SCREENHEIGHT + 30)
    Form1.Show
    'initialize Direct3D
    InitDirect3D Me.hwnd, SCREENWIDTH, SCREENHEIGHT, FULLSCREEN
    'get reference to the back buffer
    Set backbuffer = d3ddev.GetBackBuffer(0, D3DBACKBUFFER_TYPE_MONO)
    'load the bitmap file
    Set castle = LoadSurface(App.Path & "\castle.bmp", 1024, 1024)
End Sub
Public Sub InitDirect3D(ByVal hwnd As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByVal bFullscreen As Boolean)
    'catch any errors here
    On Local Error GoTo fatal_error
    'create the DirectX object
    Set dx = New DirectX8
    'create the Direct3D object
    Set d3d = dx.Direct3DCreate()
    If d3d Is Nothing Then
        MsgBox "Error initializing Direct3D!"
        Shutdown
    End If
    'tell D3D to use the current color depth
    d3d.GetAdapterDisplayMode D3DADAPTER_DEFAULT, dispmode
    'set the display settings used to create the device
    Dim d3dpp As D3DPRESENT_PARAMETERS
    d3dpp.hDeviceWindow = hwnd
    d3dpp.BackBufferCount = 1
    d3dpp.BackBufferWidth = lWidth
    d3dpp.BackBufferHeight = lHeight
    d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
    d3dpp.BackBufferFormat = dispmode.Format
    'set windowed or fullscreen mode
    If bFullscreen Then
        d3dpp.Windowed = 0
    Else
        d3dpp.Windowed = 1
    End If
    'chapter 9
    d3dpp.MultiSampleType = D3DMULTISAMPLE_NONE
    d3dpp.AutoDepthStencilFormat = D3DFMT_D32
    'create the D3D primary device
    Set d3ddev = d3d.CreateDevice( _
        D3DADAPTER_DEFAULT, _
        D3DDEVTYPE_HAL, _
        hwnd, _
        D3DCREATE_SOFTWARE_VERTEXPROCESSING, _
        d3dpp)

    If d3ddev Is Nothing Then
        MsgBox "Error creating the Direct3D device!"
        Shutdown
    End If
    Exit Sub
fatal_error:
    MsgBox "Critical error in Start_Direct3D!"
    Shutdown
End Sub
Private Function LoadSurface( _
    ByVal filename As String, _
    ByVal width As Long, _
    ByVal height As Long) _
    As Direct3DSurface8
    On Local Error GoTo fatal_error
    Dim surf As Direct3DSurface8
    'return error by default
    Set LoadSurface = Nothing
    'create the new surface
    Set surf = d3ddev.CreateImageSurface(width, height, dispmode.Format)
    If surf Is Nothing Then
        MsgBox "Error creating surface!"
        Exit Function
    End If
    'load surface from file
    d3dx.LoadSurfaceFromFile _
        surf, _
        ByVal 0, _
        ByVal 0, _
        filename, _
        ByVal 0, _
        D3DX_DEFAULT, _
        0, _
        ByVal 0

    If surf Is Nothing Then
        MsgBox "Error loading " & filename & "!"
        Exit Function
    End If
    'return the new surface
    Set LoadSurface = surf
fatal_error:
    Exit Function
End Function
Private Sub DrawTile( _
    ByRef source As Direct3DSurface8, _
    ByVal sourcex As Long, _
    ByVal sourcey As Long, _
    ByVal width As Long, _
    ByVal height As Long, _
    ByVal destx As Long, _
    ByVal desty As Long)
    'create a RECT to describe the source image
    Dim sourceRect As DxVBLibA.RECT
    'set the upper left corner of the source image
    sourceRect.Left = sourcex
    sourceRect.Top = sourcey
    'set the bottom right corner of the source image
    sourceRect.Right = sourcex + width
    sourceRect.bottom = sourcey + height
    'create a POINT to define the destination
    Dim point1 As DxVBLibA.point
    'set the upper left corner of where to draw the image
    point1.x = destx
    point1.y = desty
    'draw the source bitmap tile image
    d3ddev.CopyRects source, sourceRect, 1, backbuffer, point1
End Sub
Private Sub Form_Paint()
    'clear the background of the screen
    d3ddev.Clear 0, ByVal 0, D3DCLEAR_TARGET, C_BLACK, 1, 0
    'draw the castle bitmap "tile" image
    DrawTile castle, 0, 0, 511, 511, 25, 25
    'send the back buffer to the screen
    d3ddev.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 27 Then Shutdown
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Shutdown
End Sub
Private Sub Shutdown()
    Set castle = Nothing
    Set d3ddev = Nothing
    Set d3d = Nothing
    Set dx = Nothing
    End
End Sub