home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Game Programming for Teens / VBGPFT.cdr / sources / chapter07 / TileScroll / Form1.frm (.txt) next >
Encoding:
Visual Basic Form  |  2004-11-06  |  10.6 KB  |  313 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    Caption         =   "Form1"
  4.    ClientHeight    =   3195
  5.    ClientLeft      =   60
  6.    ClientTop       =   345
  7.    ClientWidth     =   4680
  8.    LinkTopic       =   "Form1"
  9.    ScaleHeight     =   3195
  10.    ScaleWidth      =   4680
  11.    StartUpPosition =   3  'Windows Default
  12. Attribute VB_Name = "Form1"
  13. Attribute VB_GlobalNameSpace = False
  14. Attribute VB_Creatable = False
  15. Attribute VB_PredeclaredId = True
  16. Attribute VB_Exposed = False
  17. '---------------------------------------------------------------
  18. ' Visual Basic Game Programming for Teens
  19. ' Chapter 6 - TileScroll program
  20. '---------------------------------------------------------------
  21. Private Declare Function GetTickCount Lib "kernel32" () As Long
  22. Option Explicit
  23. Option Base 0
  24. Const MAPWIDTH As Long = 25
  25. Const MAPHEIGHT As Long = 18
  26. Const RAWMAPDATA As String = _
  27. "81,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82,82," & _
  28. "83,91,4,4,4,4,4,4,4,4,4,4,4,4,4,104,4,94,4,4,4,4,4,94,4,93,91,4,14," & _
  29. "84,96,4,4,24,4,94,4,137,94,4,4,4,4,4,4,114,4,14,4,4,93,91,4,4,4,4,4," & _
  30. "4,4,104,4,4,4,4,4,24,4,4,4,4,4,4,4,132,4,93,91,4,96,4,132,4,4,4,4,4," & _
  31. "4,4,4,4,4,4,4,96,4,24,4,96,4,4,93,91,4,4,4,4,4,4,14,4,4,4,132,4,4," & _
  32. "114,4,4,4,4,4,4,4,137,4,93,91,4,84,114,4,94,4,4,4,4,4,114,4,4,4,4,4," & _
  33. "4,4,84,4,4,4,94,93,91,4,4,4,96,4,132,4,4,4,114,104,4,4,4,4,4,137,4,4," & _
  34. "132,4,4,4,93,91,4,24,4,4,4,4,4,4,96,4,4,84,4,4,4,94,4,4,4,4,4,14,4," & _
  35. "93,91,4,4,4,4,4,4,4,4,4,4,4,4,24,4,4,4,4,4,4,4,4,4,4,93,91,4,4,4,114," & _
  36. "4,94,4,4,137,4,4,4,4,104,4,4,4,96,4,94,4,96,4,93,91,4,137,84,4,4,4,4," & _
  37. "4,4,4,4,4,4,4,14,4,4,4,4,4,4,4,4,93,91,4,4,4,4,14,4,4,4,4,4,114,96,4," & _
  38. "4,4,4,4,4,132,4,137,4,114,93,91,94,4,132,4,4,4,4,4,4,94,4,104,4,24,4," & _
  39. "4,4,4,4,4,4,4,4,93,91,4,4,4,4,4,96,4,24,4,4,4,4,4,4,4,4,84,4,4,14,4," & _
  40. "96,4,93,91,4,4,4,4,94,4,4,4,4,4,132,4,4,4,14,4,4,4,114,4,4,4,4,93,91," & _
  41. "4,14,4,4,4,4,4,4,4,96,4,4,4,4,4,4,4,4,4,4,94,4,4,93,101,102,102,102," & _
  42. "102,102,102,102,102,102,102,102,102,102,102,102,102,102,102,102,102," & _
  43. "102,102,102,103"
  44. 'customize the program here
  45. Const SCREENWIDTH As Long = 800
  46. Const SCREENHEIGHT As Long = 600
  47. Const FULLSCREEN As Boolean = False
  48. Const GAMEWORLDWIDTH As Long = 1600
  49. Const GAMEWORLDHEIGHT As Long = 1152
  50. Const TILEWIDTH As Long = 64
  51. Const TILEHEIGHT As Long = 64
  52. 'the DirectX objects
  53. Dim dx As DirectX8
  54. Dim d3d As Direct3D8
  55. Dim d3dx As New D3DX8
  56. Dim dispmode As D3DDISPLAYMODE
  57. Dim d3dpp As D3DPRESENT_PARAMETERS
  58. Dim d3ddev As Direct3DDevice8
  59. 'some surfaces
  60. Dim backbuffer As Direct3DSurface8
  61. Dim gameworld As Direct3DSurface8
  62. 'map data
  63. Dim mapdata(MAPWIDTH * MAPHEIGHT) As Integer
  64. 'scrolling values
  65. Const STEP As Long = 8
  66. Dim ScrollX As Long
  67. Dim ScrollY As Long
  68. Dim SpeedX As Integer
  69. Dim SpeedY As Integer
  70. Private Sub Form_Load()
  71.     'set up the main form
  72.     Form1.Caption = "TileScroll"
  73.     Form1.ScaleMode = 3
  74.     Form1.width = Screen.TwipsPerPixelX * (SCREENWIDTH + 12)
  75.     Form1.height = Screen.TwipsPerPixelY * (SCREENHEIGHT + 30)
  76.     Form1.Show
  77.     'initialize Direct3D
  78.     InitDirect3D Me.hwnd, SCREENWIDTH, SCREENHEIGHT, FULLSCREEN
  79.     'get reference to the back buffer
  80.     Set backbuffer = d3ddev.GetBackBuffer(0, D3DBACKBUFFER_TYPE_MONO)
  81.     'create gameworld map in memory using tiles
  82.     ConvertMapDataToArray
  83.     BuildGameWorld
  84.     'this helps to keep a steady framerate
  85.     Dim start As Long
  86.     start = GetTickCount()
  87.     'main loop
  88.     Do While (True)
  89.         'update the scrolling viewport
  90.         ScrollScreen
  91.         
  92.         'set the screen refresh to about 40 fps
  93.         If GetTickCount - start > 25 Then
  94.             d3ddev.Present ByVal 0, ByVal 0, 0, ByVal 0
  95.             start = GetTickCount
  96.             DoEvents
  97.         End If
  98.     Loop
  99. End Sub
  100. Public Sub ConvertMapDataToArray()
  101.     Dim pos As Long
  102.     Dim s As String
  103.     Dim value As String
  104.     Dim index As Long
  105.     'convert the rawmapdata string to an array of integers
  106.     For pos = 1 To Len(RAWMAPDATA)
  107.         
  108.         'get next character
  109.         s = Mid$(RAWMAPDATA, pos, 1)
  110.         
  111.         'tiles are separated by commas
  112.         If s = "," Then
  113.         
  114.             If Len(value) > 0 Then
  115.                 
  116.                 'store tile # in array
  117.                 mapdata(index) = CInt(value - 1)
  118.                 
  119.                 index = index + 1
  120.             End If
  121.             
  122.             'get ready for next #
  123.             value = ""
  124.             s = ""
  125.             
  126.         Else
  127.             value = value & s
  128.         End If
  129.     Next pos
  130. End Sub
  131. Public Sub BuildGameWorld()
  132.     Dim X As Long
  133.     Dim Y As Long
  134.     Dim cols As Long
  135.     Dim rows As Long
  136.     Dim tiles As Direct3DSurface8
  137.     'load the bitmap file containing all the tiles
  138.     Set tiles = LoadSurface(App.Path & "\map1.bmp", 1024, 640)
  139.     'create the scrolling game world bitmap
  140.     Set gameworld = d3ddev.CreateImageSurface(GAMEWORLDWIDTH, GAMEWORLDHEIGHT, dispmode.Format)
  141.     If gameworld Is Nothing Then
  142.         MsgBox "Error creating working surface!"
  143.         Shutdown
  144.     End If
  145.     'fill the gameworld bitmap with tiles
  146.     For Y = 0 To MAPHEIGHT - 1
  147.         For X = 0 To MAPWIDTH - 1
  148.             DrawTile tiles, mapdata(Y * MAPWIDTH + X), 64, 64, 16, gameworld, X * 64, Y * 64
  149.         Next X
  150.     Next Y
  151.     'now the tiles bitmap is no longer needed
  152.     Set tiles = Nothing
  153. End Sub
  154. Private Sub DrawTile( _
  155.     ByRef source As Direct3DSurface8, _
  156.     ByVal tilenum As Long, _
  157.     ByVal width As Long, _
  158.     ByVal height As Long, _
  159.     ByVal columns As Long, _
  160.     ByVal dest As Direct3DSurface8, _
  161.     ByVal destx As Long, _
  162.     ByVal desty As Long)
  163.     'create a RECT to describe the source image
  164.     Dim r As DxVBLibA.RECT
  165.     'set the upper left corner of the source image
  166.     r.Left = (tilenum Mod columns) * width
  167.     r.Top = (tilenum \ columns) * height
  168.     'set the bottom right corner of the source image
  169.     r.Right = r.Left + width
  170.     r.bottom = r.Top + height
  171.     'create a POINT to define the destination
  172.     Dim point As DxVBLibA.point
  173.     'set the upper left corner of where to draw the image
  174.     point.X = destx
  175.     point.Y = desty
  176.     'draw the source bitmap tile image
  177.     d3ddev.CopyRects source, r, 1, dest, point
  178. End Sub
  179. Public Sub ScrollScreen()
  180.     'update horizontal scrolling position and speed
  181.     ScrollX = ScrollX + SpeedX
  182.     If (ScrollX < 0) Then
  183.         ScrollX = 0
  184.         SpeedX = 0
  185.     ElseIf ScrollX > GAMEWORLDWIDTH - SCREENWIDTH Then
  186.         ScrollX = GAMEWORLDWIDTH - SCREENWIDTH
  187.         SpeedX = 0
  188.     End If
  189.     'update vertical scrolling position and speed
  190.     ScrollY = ScrollY + SpeedY
  191.     If ScrollY < 0 Then
  192.         ScrollY = 0
  193.         SpeedY = 0
  194.     ElseIf ScrollY > GAMEWORLDHEIGHT - SCREENHEIGHT Then
  195.         ScrollY = GAMEWORLDHEIGHT - SCREENHEIGHT
  196.         SpeedY = 0
  197.     End If
  198.     'set dimensions of the source image
  199.     Dim r As DxVBLibA.RECT
  200.     r.Left = ScrollX
  201.     r.Top = ScrollY
  202.     r.Right = ScrollX + SCREENWIDTH
  203.     r.bottom = ScrollY + SCREENHEIGHT
  204.     'set the destination point
  205.     Dim point As DxVBLibA.point
  206.     point.X = 0
  207.     point.Y = 0
  208.     'draw the current game world view
  209.     d3ddev.CopyRects gameworld, r, 1, backbuffer, point
  210. End Sub
  211. Public Sub InitDirect3D( _
  212.     ByVal hwnd As Long, _
  213.     ByVal lWidth As Long, _
  214.     ByVal lHeight As Long, _
  215.     ByVal bFullscreen As Boolean)
  216.     'catch any errors here
  217.     On Local Error GoTo fatal_error
  218.     'create the DirectX object
  219.     Set dx = New DirectX8
  220.     'create the Direct3D object
  221.     Set d3d = dx.Direct3DCreate()
  222.     If d3d Is Nothing Then
  223.         MsgBox "Error initializing Direct3D!"
  224.         Shutdown
  225.     End If
  226.     'tell D3D to use the current color depth
  227.     d3d.GetAdapterDisplayMode D3DADAPTER_DEFAULT, dispmode
  228.     'set the display settings used to create the device
  229.     Dim d3dpp As D3DPRESENT_PARAMETERS
  230.     d3dpp.hDeviceWindow = hwnd
  231.     d3dpp.BackBufferCount = 1
  232.     d3dpp.BackBufferWidth = lWidth
  233.     d3dpp.BackBufferHeight = lHeight
  234.     d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
  235.     d3dpp.BackBufferFormat = dispmode.Format
  236.     'set windowed or fullscreen mode
  237.     If bFullscreen Then
  238.         d3dpp.Windowed = 0
  239.     Else
  240.         d3dpp.Windowed = 1
  241.     End If
  242.     'chapter 9
  243.     d3dpp.MultiSampleType = D3DMULTISAMPLE_NONE
  244.     d3dpp.AutoDepthStencilFormat = D3DFMT_D32
  245.     'create the D3D primary device
  246.     Set d3ddev = d3d.CreateDevice( _
  247.         D3DADAPTER_DEFAULT, _
  248.         D3DDEVTYPE_HAL, _
  249.         hwnd, _
  250.         D3DCREATE_SOFTWARE_VERTEXPROCESSING, _
  251.         d3dpp)
  252.         
  253.     If d3ddev Is Nothing Then
  254.         MsgBox "Error creating the Direct3D device!"
  255.         Shutdown
  256.     End If
  257.     Exit Sub
  258. fatal_error:
  259.     MsgBox "Critical error in Start_Direct3D!"
  260.     Shutdown
  261. End Sub
  262. Private Function LoadSurface( _
  263.     ByVal filename As String, _
  264.     ByVal width As Long, _
  265.     ByVal height As Long) _
  266.     As Direct3DSurface8
  267.     On Local Error GoTo fatal_error
  268.     Dim surf As Direct3DSurface8
  269.     'return error by default
  270.     Set LoadSurface = Nothing
  271.     'create the new surface
  272.     Set surf = d3ddev.CreateImageSurface(width, height, dispmode.Format)
  273.     If surf Is Nothing Then
  274.         MsgBox "Error creating surface!"
  275.         Exit Function
  276.     End If
  277.     'load surface from file
  278.     d3dx.LoadSurfaceFromFile surf, ByVal 0, ByVal 0, filename, _
  279.         ByVal 0, D3DX_DEFAULT, 0, ByVal 0
  280.         
  281.     If surf Is Nothing Then
  282.         MsgBox "Error loading " & filename & "!"
  283.         Exit Function
  284.     End If
  285.     'return the new surface
  286.     Set LoadSurface = surf
  287. fatal_error:
  288.     Exit Function
  289. End Function
  290. Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  291.     'move mouse on left side to scroll left
  292.     If X < SCREENWIDTH / 2 Then SpeedX = -STEP
  293.     'move mouse on right side to scroll right
  294.     If X > SCREENWIDTH / 2 Then SpeedX = STEP
  295.     'move mouse on top half to scroll up
  296.     If Y < SCREENHEIGHT / 2 Then SpeedY = -STEP
  297.     'move mouse on bottom half to scroll down
  298.     If Y > SCREENHEIGHT / 2 Then SpeedY = STEP
  299. End Sub
  300. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  301.     If KeyCode = 27 Then Shutdown
  302. End Sub
  303. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  304.     Shutdown
  305. End Sub
  306. Private Sub Shutdown()
  307.     Set gameworld = Nothing
  308.     Set d3ddev = Nothing
  309.     Set d3d = Nothing
  310.     Set dx = Nothing
  311.     End
  312. End Sub
  313.