home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD149932152001.psc / frmMain.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  2001-02-15  |  9.7 KB  |  275 lines
  1. VERSION 5.00
  2. Begin VB.Form frmMain 
  3.    BackColor       =   &H00000000&
  4.    BorderStyle     =   0  'None
  5.    Caption         =   "Cyril's SpaceQuest"
  6.    ClientHeight    =   3195
  7.    ClientLeft      =   0
  8.    ClientTop       =   0
  9.    ClientWidth     =   4680
  10.    Icon            =   "frmMain.frx":0000
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   3195
  13.    ScaleWidth      =   4680
  14.    ShowInTaskbar   =   0   'False
  15.    StartUpPosition =   3  'Windows Default
  16. Attribute VB_Name = "frmMain"
  17. Attribute VB_GlobalNameSpace = False
  18. Attribute VB_Creatable = False
  19. Attribute VB_PredeclaredId = True
  20. Attribute VB_Exposed = False
  21. Private Sub Form_Load()
  22. INITVars
  23. 'First Hide the Mouse
  24. ShowCursor 0
  25. 'Initialise the DirectX Components
  26. DXMain_Init
  27. End Sub
  28. 'This randomly chooses music to play
  29. Sub Main_PlayMusic()
  30. Dim i As Integer
  31.     Call DM_CreateLoaderPerformance(frmMain.hWnd)
  32.     Randomize
  33.     i = Int((3 * Rnd) + 1)
  34.     If i = 1 Then
  35.         Call DM_LoadPlayMidi("music.Mid")
  36.     ElseIf i = 2 Then
  37.         Call DM_LoadPlayMidi("music2.Mid")
  38.     Else
  39.         Call DM_LoadPlayMidi("Electric.Mid")
  40.     End If
  41. End Sub
  42. Private Sub DXMain_Init()
  43. 'On Error GoTo errorout:
  44. Set ddMain = DXMain.DirectDrawCreate("") 'Create an instance of DirectDraw
  45. Set dsMain = DXMain.DirectSoundCreate("")
  46. Me.Show 'Show the form
  47. 'Set the co-operative level of DirectX
  48. ddMain.SetCooperativeLevel frmMain.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE
  49. ddMain.SetDisplayMode 320, 240, 16, 0, DDSDM_DEFAULT 'Set The Screen Size
  50. 'Set up the primary screen surface to show on the screen
  51. sdMain.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  52. sdMain.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
  53. sdMain.lBackBufferCount = 1
  54. Set dsPrim = ddMain.CreateSurface(sdMain) 'This sets the primary surface
  55. 'Create a Backbuffer, to draw on in the background.
  56. 'This is used to increase animation and reduce flicker
  57. Dim ddsCaps As DDSCAPS2
  58. ddsCaps.lCaps = DDSCAPS_BACKBUFFER
  59. Set dsBbuf = dsPrim.GetAttachedSurface(ddsCaps)
  60. Do_SetStars 'This makes the Stars array and finalises attributes
  61. DxMain_InitSurfaces 'Load The Surfaces
  62. sAngle = 0 'The turning angle
  63. sSpd = 1 'the speed multiplier
  64. 'The DirectInput Handler to control the star movements
  65. Set diMain = DXMain.DirectInputCreate
  66. Set diDev = diMain.CreateDevice("GUID_SysKeyboard")
  67. diDev.SetCommonDataFormat DIFORMAT_KEYBOARD
  68. diDev.SetCooperativeLevel frmMain.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
  69. diDev.Acquire
  70. dsBbuf.SetForeColor vbRed
  71. dsBbuf.SetFont Me.Font
  72. Call DM_UnloadStopMidi
  73. 'Plays music
  74. Call Main_PlayMusic
  75. 'This is the game loop, it's infinite and fast, however it's slow on older PCs
  76.     Do_Keys 'Check for keyboard input
  77.     DXMain_Blit  'Draw The Screen
  78.     DoEvents
  79. 'errorout:
  80. '    DXMain_EndIT
  81. End Sub
  82. Private Sub DXMain_Blit()
  83. 'This is the main drawing routine
  84. 'All the stars are written onto a backbuffer and then the backbuffer is drawn
  85. 'onto the primary surface
  86. 'On Error GoTo errorout
  87. Dim rback As RECT 'A rect is used to set the picture size
  88. Dim Xas As Integer
  89. dsBbuf.SetFillColor 0
  90. dsBbuf.DrawBox 0, 0, 320, 240
  91. 'Set the Star Height to 6 pixels
  92. rback.Top = 0: rback.Bottom = 3
  93. 'Draw and move the 150 stars
  94. For Xas = 0 To 149
  95.     'Define the picture used using the picture number set
  96.     'In the array, this is cleaner faster and easier then
  97.     'Using a single bitmap for each star
  98.     rback.Left = sStar(Xas, 3) * 3
  99.     rback.Right = rback.Left + 3
  100.     'Draw the star onto the backbuffer
  101.     dsBbuf.BltFast sStar(Xas, 0), sStar(Xas, 1), dsStar, rback, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
  102.     'Move the stars using sine and cosine
  103.     sStar(Xas, 1) = sStar(Xas, 1) + (sStar(Xas, 2) * Cos(sAngle) * sSpd)
  104.     sStar(Xas, 0) = sStar(Xas, 0) + (sStar(Xas, 2) * Sin(sAngle) * sSpd)
  105.     'Check if the star is off the screen and if so, put them back
  106.     If sStar(Xas, 1) < 0 Then sStar(Xas, 1) = 240 + sStar(Xas, 1)
  107.     If sStar(Xas, 1) > 240 Then sStar(Xas, 1) = sStar(Xas, 1) - 240
  108.     If sStar(Xas, 0) < 0 Then sStar(Xas, 0) = 320 + sStar(Xas, 0)
  109.     If sStar(Xas, 0) > 320 Then sStar(Xas, 0) = sStar(Xas, 0) - 320
  110. Next Xas
  111. 'Blit The Ship
  112. ShipX = ShipX + ShipXShift
  113. ShipY = ShipY + ShipYShift
  114. If ShipX <= 0 Then ShipX = 0
  115. If ShipX > 280 Then ShipX = 280
  116. If ShipY < 0 Then ShipY = 0
  117. If ShipY > 200 Then ShipY = 200
  118. dsBbuf.BltFast ShipX, ShipY, dsShip, rShip, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
  119. ShipXShift = 0
  120. ShipYShift = 0
  121. If (ShipX > StoneX And ShipX < StoneX + rStone.Right And ShipY >= StoneY And ShipY < StoneY + rStone.Bottom) Then
  122.     DXMain_EndIT
  123. End If
  124. 'Check if Missile Hits Stone
  125. If Not (MissX > StoneX And MissX < StoneX + rStone.Right And MissY >= StoneY And MissY < StoneY + rStone.Bottom) Then
  126.     'Blit The Missile
  127.     If MissileVisi = True Then
  128.         If MissX = 0 Then
  129.             MissX = ShipX + 16
  130.             MissY = ShipY - 12
  131.         End If
  132.         dsBbuf.BltFast MissX, MissY, dsMissile, rMissile, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
  133.         MissY = MissY - 6
  134.         If MissY < 0 Then MissileVisi = False
  135.     End If
  136.     'STONE BLIT
  137.     dsBbuf.BltFast StoneX, StoneY, dsStone, rStone, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
  138.     StoneY = StoneY + StoneSpeed
  139.     If StoneY > 300 Then StoneY = 0
  140.     DoEvents
  141.     MissileVisi = False
  142.     StoneY = 0
  143.     MissX = 0
  144.     MissY = 0
  145.     Randomize
  146.     StoneX = Int((200 - 1 + 1) * Rnd + 1)
  147.     Score = Score + 10
  148.     StoneSpeed = StoneSpeed + 0.03
  149. End If
  150. 'Blit The Text
  151. dsBbuf.DrawText 3, 3, "Score: " & Score, False
  152. dsBbuf.DrawText 225, 224, "Cyril's SpaceQuest", False
  153. dsPrim.Flip Nothing, DDFLIP_WAIT
  154. 'errorout:
  155. End Sub
  156. Private Sub Do_Keys()
  157. 'This sub processes the DirectInput Commands
  158. Dim Xas As Integer
  159. diDev.GetDeviceStateKeyboard diState
  160. If diState.Key(DIK_ESCAPE) <> 0 Then DXMain_EndIT
  161. 'The left key reduces the angle, if it gets below zero it's set to 2pi
  162. If diState.Key(DIK_LEFT) <> 0 Then
  163.     sAngle = sAngle + 0.025
  164.     If sAngle > 6.28 Then sAngle = 0
  165.     ShipXShift = -ShipSpeed
  166. End If
  167. 'The right key increases the angle if its above 2pi its reduced to zero
  168. If diState.Key(DIK_RIGHT) <> 0 Then
  169.     sAngle = sAngle - 0.025
  170.     If sAngle < 0 Then sAngle = 6.28
  171.     ShipXShift = ShipSpeed
  172. End If
  173. 'The down key reduces speed
  174. If diState.Key(DIK_DOWN) Then
  175. '    sSpd = sSpd * 0.99
  176.     ShipYShift = ShipSpeed
  177. End If
  178. 'The up key increases speed
  179. If diState.Key(DIK_UP) <> 0 Then
  180. '    sSpd = sSpd * 1.01
  181. '    If sSpd > 25 Then sSpd = 25
  182.     ShipYShift = -ShipSpeed
  183. End If
  184. If diState.Key(DIK_ADD) <> 0 Then
  185.     ShipSpeed = ShipSpeed + 0.1
  186. End If
  187. If diState.Key(DIK_SUBTRACT) <> 0 Then
  188.     ShipSpeed = ShipSpeed - 0.1
  189.     If ShipSpeed <= 0 Then ShipSpeed = 1
  190. End If
  191. If Not MissileVisi Then
  192.     If diState.Key(DIK_SPACE) <> 0 Then
  193.         MissileVisi = True
  194.         MissX = 0
  195.         MissY = 0
  196.     End If
  197.     PlaySound App.Path & "\BLIP.wav", 0, SND_FILENAME Or SND_ASYNC
  198. End If
  199. End Sub
  200. Private Sub DXMain_EndIT()
  201. 'This sub unloads DirectX and puts control back to the computer
  202. ShowCursor 1
  203. ddMain.RestoreDisplayMode 'Restores the old resolution
  204. ddMain.SetCooperativeLevel Me.hWnd, DDSCL_NORMAL
  205. diDev.Unacquire 'Disable directinput
  206. DoEvents
  207. DoEvents
  208. MsgBox "That's the end." & vbCrLf & "If you liked this game vote for it."
  209. End Sub
  210. Private Sub DxMain_InitSurfaces()
  211. 'This sub loads the surface containing the five star pictures
  212. 'THE STARS INIT
  213. Dim Clrkey As DDCOLORKEY 'Creates a color key
  214. Dim Key2 As DDCOLORKEY 'Here's a Color Key
  215. Dim Key3 As DDCOLORKEY
  216. Clrkey.low = 0
  217. Clrkey.high = 0 'Makes the stars transparent
  218. sdStar.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
  219. sdStar.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  220. sdStar.lWidth = 15
  221. sdStar.lHeight = 3 'The size of the star
  222. Set dsStar = ddMain.CreateSurfaceFromFile(App.Path & "\Stars.bmp", sdStar) 'Load the bitmap
  223. dsStar.SetColorKey DDCKEY_SRCBLT, Clrkey 'Set The ColorKey
  224. 'THE SHIP INIT
  225. sdShip.lFlags = DDSD_CAPS
  226. sdShip.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  227. Set dsShip = ddMain.CreateSurfaceFromFile(App.Path & "\SHIP.BMP", sdShip)
  228. rShip.Bottom = sdShip.lHeight
  229. rShip.Right = sdShip.lWidth
  230. Key2.low = 0
  231. Key2.high = 0
  232. dsShip.SetColorKey DDCKEY_SRCBLT, Key2
  233. 'THE missile INIT
  234. sdMissile.lFlags = DDSD_CAPS
  235. sdMissile.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  236. Set dsMissile = ddMain.CreateSurfaceFromFile(App.Path & "\missil.BMP", sdMissile)
  237. rMissile.Bottom = sdMissile.lHeight
  238. rMissile.Right = sdMissile.lWidth
  239. Key2.low = 0
  240. Key2.high = 0
  241. dsMissile.SetColorKey DDCKEY_SRCBLT, Key2
  242. 'THE Stone INIT
  243. sdStone.lFlags = DDSD_CAPS
  244. sdStone.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
  245. Set dsStone = ddMain.CreateSurfaceFromFile(App.Path & "\stone.BMP", sdStone)
  246. rStone.Bottom = sdStone.lHeight
  247. rStone.Right = sdStone.lWidth
  248. Key2.low = 0
  249. Key2.high = 0
  250. dsStone.SetColorKey DDCKEY_SRCBLT, Key2
  251. End Sub
  252. Private Sub Do_SetStars()
  253. 'In this routine the stars are loaded into an array
  254. 'all values are random
  255. Dim Xas As Integer
  256. For Xas = 0 To 149 'There are 150 Stars
  257.     sStar(Xas, 0) = Int(Rnd * 320) 'The Verticals Pos
  258.     sStar(Xas, 1) = Int(Rnd * 240) 'The Horizontal Pos
  259.     sStar(Xas, 2) = Int(Rnd * 5) 'The Speed
  260.     sStar(Xas, 3) = Fix(4 - Int(sStar(Xas, 2))) 'Calculate what star it is
  261. Next Xas
  262. ' Note: The bitmap used with this sample uses 5 stars
  263. ' The first star is the brightest and the last one the
  264. ' Darkest. To add realism the fastest moving stars will
  265. ' Be the ones using the first picture because it is the
  266. ' Closest to calculate this we round the star speed and
  267. ' Invert the number...
  268. End Sub
  269. Private Sub INITVars()
  270. ShipX = 200
  271. ShipY = 200
  272. ShipSpeed = 4
  273. StoneSpeed = 1
  274. End Sub
  275.