home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD15673312001.psc / frmMain.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-02-25  |  6.4 KB  |  196 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BackColor       =   &H00000080&
  4.    BorderStyle     =   0  'None
  5.    Caption         =   "frmMain"
  6.    ClientHeight    =   4425
  7.    ClientLeft      =   0
  8.    ClientTop       =   0
  9.    ClientWidth     =   7380
  10.    Icon            =   "frmMain.frx":0000
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   295
  13.    ScaleMode       =   0  'User
  14.    ScaleWidth      =   488.846
  15.    ShowInTaskbar   =   0   'False
  16.    StartUpPosition =   3  'Windows Default
  17.    Begin VB.Timer Timer1 
  18.       Interval        =   1000
  19.       Left            =   1320
  20.       Top             =   2520
  21.    End
  22. Attribute VB_Name = "frmMain"
  23. Attribute VB_GlobalNameSpace = False
  24. Attribute VB_Creatable = False
  25. Attribute VB_PredeclaredId = True
  26. Attribute VB_Exposed = False
  27. Option Explicit
  28. Private Sub Form_KeyPress(KeyAscii As Integer)
  29. If KeyAscii = 27 Then
  30.     Unload Me
  31.     DxEnd
  32. End If
  33. End Sub
  34. Private Sub Form_Load()
  35. ShowCursor 0 'Hides The Cursor
  36. InitDx 'Initializes Directx
  37. INITVars 'Initialize some variables
  38. Game_Loop 'Every Game `Has One of This
  39. End Sub
  40. Public Sub InitDx()
  41. Dim rc(1) As RECT
  42. Set ddMain = DXMain.DirectDrawCreate("") 'Set the ddMain object to a new instance of DirectDraw
  43. Me.Show 'Shows the form
  44. ddMain.SetCooperativeLevel Me.hWnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN 'We want to monopolize the computer and display the thing in full screen
  45. ddMain.SetDisplayMode 640, 480, 16, 0, DDSDM_DEFAULT 'sets the screen size and bit depth, DDSM_DDEFAULT is same in all projects
  46. 'Describe the Primary Surface
  47. sdMain.lFlags = DDSD_CAPS 'Enables the DDSD_CAPS member
  48. sdMain.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE  'This is a primary surface, is a complex surface and can be flipped
  49. 'Describes the back buffer
  50. sdBack.ddsCaps.lCaps = DDSCAPS_SYSTEMMEMORY
  51. sdBack.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
  52. sdBack.lWidth = 640
  53. sdBack.lHeight = 480
  54. Set dsPrim = ddMain.CreateSurface(sdMain) 'Make a new surface that fits our description
  55. Set dsBbuf = ddMain.CreateSurface(sdBack) 'Mack the back buffer
  56. Set dsClip = ddMain.CreateClipper(0) 'Create the clipper object
  57. dsClip.SetHWnd frmMain.hWnd
  58. dsBbuf.SetClipper dsClip
  59. dsPrim.SetClipper dsClip
  60. 'The DirectInput Initialization
  61. Set diMain = DXMain.DirectInputCreate 'Create an instance of DirectInput
  62. Set diDev = diMain.CreateDevice("GUID_SysKeyboard") 'Create an instance of the device
  63. diDev.SetCommonDataFormat DIFORMAT_KEYBOARD 'Set data format to keyboard
  64. diDev.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE 'Set Co-operative level to Background and non_exclusive to give other applications some room
  65. diDev.Acquire 'Get The Device
  66. dsBbuf.SetForeColor vbWhite   'Set the forecolor to white to draw text
  67. dsBbuf.SetFont Me.Font  'Set the font to the form font
  68. End Sub
  69. Private Sub Form_Unload(Cancel As Integer)
  70. ShowCursor 1
  71. End Sub
  72. Public Sub Game_Loop()
  73.     Do_Keys 'Check out the key action
  74.     DxBlit 'Blit The Sprites
  75.     DoEvents
  76. End Sub
  77. Public Sub Do_Keys()
  78. diDev.GetDeviceStateKeyboard diState
  79. If diState.Key(DIK_ESCAPE) <> 0 Then
  80.     DxEnd
  81. End If
  82. 'Check right key press
  83. If diState.Key(DIK_RIGHT) <> 0 Then
  84.     Car.ShiftRight
  85. End If
  86. 'Check left key press
  87. If diState.Key(DIK_LEFT) <> 0 Then
  88.     Car.ShiftLeft
  89. End If
  90. 'Check Up key press
  91. If diState.Key(DIK_UP) <> 0 Then
  92.     Car.ShiftUP
  93. End If
  94. 'Check left key press
  95. If diState.Key(DIK_DOWN) <> 0 Then
  96.     Car.ShiftDown
  97. End If
  98. End Sub
  99. Private Sub DxBlit()
  100. Dim rect2 As RECT
  101. Dim DestRect As RECT
  102. FPS = FPS + 1
  103. dsBbuf.SetFillColor Me.BackColor
  104. 'dsBbuf.SetForeColor Me.BackColor
  105. dsBbuf.DrawBox 0, 0, 640, 480
  106. dsBbuf.SetForeColor vbWhite
  107. dsBbuf.DrawText 540, 440, "By: Cyril M Gupta", False
  108. dsBbuf.DrawText 540, 460, "FPS: " & FPSTotal, False
  109. dsBbuf.DrawText 10, 100, "Score: " & Score, False
  110. dsBbuf.DrawText 10, 150, "Speed: " & SPEED + ShiftSpeed, False
  111. dsBbuf.DrawText 540, 460, "FPS: " & FPSTotal, False
  112. dsBbuf.SetForeColor Me.ForeColor
  113. 'Blit The Road
  114. 'With Road
  115. '    dsBbuf.Blt .DestRect, .dsRoad, .RECTO, DDBLT_WAIT Or DDBLT_KEYSRC
  116. 'End With
  117. ''Blit The Guides
  118. With Guide(0)
  119.     dsBbuf.Blt .DestRect, .dsGuide, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  120.     .ShiftDown
  121. End With
  122. With Guide(1)
  123.     dsBbuf.Blt .DestRect, .dsGuide, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  124.     .ShiftDown
  125. End With
  126. With Guide(2)
  127.     dsBbuf.Blt .DestRect, .dsGuide, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  128.     .ShiftDown
  129. End With
  130. 'Fuel Logo
  131. With Feed
  132.     dsBbuf.Blt .DestRect, .dsFeed, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  133. End With
  134. 'Blit The Patch
  135. With Patch
  136.     dsBbuf.Blt .DestRect, .dsPatch, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  137.     .ShiftDown
  138. End With
  139. 'Blit The Fuel
  140. With Fuel
  141.     dsBbuf.Blt .DestRect, .dsFuel, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  142.     .ShiftDown
  143. End With
  144. 'Blit The Car
  145. With Car
  146.     dsBbuf.Blt .DestRect, .dsCar, .RECTO, DDBLT_KEYSRC Or DDBLT_WAIT
  147. End With
  148. dsPrim.Blt DestRect, dsBbuf, rect2, DDBLT_WAIT
  149. If Fuel.DestRect.Left >= Car.DestRect.Left And _
  150.    Fuel.DestRect.Right <= Car.DestRect.Right And _
  151.    Fuel.DestRect.Top >= Car.DestRect.Top And _
  152.    Fuel.DestRect.Bottom <= Car.DestRect.Bottom Then
  153.    Fuel.YPos = 480
  154.    Score = Score + 300
  155. '    Debug.Print "Car: "; Car.DestRect.Left
  156. '    Debug.Print "Feed: "; Fuel.DestRect.Left
  157. End If
  158. If Patch.DestRect.Left >= Car.DestRect.Left And Patch.DestRect.Right <= Car.DestRect.Right Or _
  159.    Patch.DestRect.Left <= Car.DestRect.Right And Patch.DestRect.Right <= Car.DestRect.Right Then
  160.     Score = Score - 10
  161. End If
  162. If Not (SPEED + ShiftSpeed) > 9 Then ShiftSpeed = ShiftSpeed + 0.001
  163. End Sub
  164. Private Sub INITVars()
  165. Set Road = New CRoad
  166. Set Car = New CCar
  167. Set Guide(0) = New CGuide
  168. Set Guide(1) = New CGuide
  169. Set Guide(2) = New CGuide
  170. Set Feed = New CFeed
  171. Set Patch = New CPatch
  172. Set Fuel = New CFuel
  173. Guide(0).XPos = 290
  174. Guide(0).YPos = 0
  175. Guide(1).XPos = 290
  176. Guide(1).YPos = 200
  177. Guide(2).XPos = 290
  178. Guide(2).YPos = 400
  179. End Sub
  180. Private Sub DxEnd()
  181. 'This sub unloads DirectX and puts control back to the computer
  182. ShowCursor 1
  183. 'This sub unloads DirectX and puts control back to the computer
  184. 'ShowCursor 1
  185. ddMain.RestoreDisplayMode 'Restores the old resolution
  186. 'ddMain.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL 'Setco-op to normal
  187. diDev.Unacquire 'Disable directinput
  188. 'DoEvents
  189. 'MsgBox "That's the end." & vbCrLf & "If you liked this game vote for it."
  190. End Sub
  191. Private Sub Timer1_Timer()
  192. FPSTotal = FPS
  193. FPS = 0
  194. 'Debug.Print FPSTotal
  195. End Sub
  196.