Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/direct2a/frmgame.frm

Visual Basic Form | 1999-10-19 | 14.1 KB | 433 lines

VERSION 5.00
Begin VB.Form frmGame
   BorderStyle     =   0  'None
   Caption         =   "Engine01"
   ClientHeight    =   5625
   ClientLeft      =   2355
   ClientTop       =   1620
   ClientWidth     =   7065
   Icon            =   "frmGame.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   375
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   471
Attribute VB_Name = "frmGame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'DDRAW ENGINE 1
'Written by Jack Hoxley, based on an example by Microsoft
'EMAIL: [e-mail]
'WEB: HTTP://WWW.Parkstonemot.freeserve.co.uk/indexfw.htm
'Because a DirectX game takes a lot of work, i am only providing you with
'the tools and basic structure or an engine.
'To create your own game, you will need to make extensive changes to
'this example. I didn't want to give away a free game engine, as that would mean
'weeks of work for no reward other than someone changing the name and re-releasing it.
'There are several  bugs in this code, such as the player going out of site at some points.
'You'll have to fix these, i'm doing it on my copy, you'll just have to work it out yourself.....
'Please Email me with any helpful hints, but no requests for source code. I don't mind explaining/
'helping, but i refuse to do the work for you.
'There are several things that you'll need, the main one is levels. As the editor is quite
'complex i might decide to keep it rather than give it away. To make levels, you will need
'to create a loading sub. Examine the one supplied, either work out how to save it or re-write your
'own one.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Explicit
Dim binit As Boolean
'~~~~~DIRECT DRAW~~~~~
Dim dx As New DirectX7
Dim dd As DirectDraw7
Dim lakesurf As DirectDrawSurface7
Dim Bloksurf As DirectDrawSurface7
Dim FruitSurf As DirectDrawSurface7
Dim primary As DirectDrawSurface7
Dim backbuffer As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd2 As DDSURFACEDESC2 'Gradient
Dim ddsd3 As DDSURFACEDESC2 'blocks
Dim ddsd4 As DDSURFACEDESC2 'used
Dim ddsd5 As DDSURFACEDESC2 'Fruit
Dim spriteWidth As Integer
Dim spriteHeight As Integer
Dim cols As Integer
Dim rows As Integer
Dim row As Integer
Dim col As Integer
Dim currentFrame As Integer
Dim brunning As Boolean
Dim CurModeActiveStatus As Boolean
Dim bRestore As Boolean
'~~~~~DIRECT INPUT~~~~~
Dim di As DirectInput
Dim diDEV As DirectInputDevice
Dim diState As DIKEYBOARDSTATE
Dim iKeyCounter As Integer
Sub Center_Screen()
SBox.X = (P1.X * 32) - 304
SBox.Y = (P1.Y * 32) - 224
'If SBox.X <= 0 Then SBox.X = 0
'If SBox.X >= 1744 Then SBox.X = 1744
'If SBox.Y >= 1056 Then SBox.Y = 1056
'If SBox.Y <= 0 Then SBox.Y = 0
If SBox.X <= 0 Then SBox.X = 0
If SBox.Y <= 0 Then SBox.Y = 0
'-------------------------------------------------
If SBox.X >= 1408 Then SBox.X = 1408
If SBox.Y >= 1056 Then SBox.Y = 1056
End Sub
Sub Check_Keys()
diDEV.GetDeviceStateKeyboard diState
For iKeyCounter = 0 To 255
If diState.key(iKeyCounter) <> 0 Then
Select Case iKeyCounter
    Case 1  'escape
    EndIt
    Case 28 'return on keyboard
    Case 59 'F1 info
    If ShowInfo = True Then
    ShowInfo = False
    Else
    ShowInfo = True
    End If
    Case 60 'F2 debug
    If ShowDebug = True Then
    ShowDebug = False
    Else
    ShowDebug = True
    End If
    Case 200 'up
    If P1.Y > 0 Then
    P1.Y = P1.Y - 1
    End If
    Case 203 'Left
    If P1.X > 0 Then
    P1.X = P1.X - 1
    End If
    Case 205 'Right
    If P1.X < 63 Then
    P1.X = P1.X + 1
    End If
    Case 208 'down
    If P1.Y < 47 Then
    P1.Y = P1.Y + 1
    End If
End Select
End If
End Sub
Sub Draw_Gradient()
On Error Resume Next
S.R = GStart.R
S.G = GStart.G
S.B = GStart.B
E.R = GEnd.R
E.G = GEnd.G
E.B = GEnd.B
Dim d As Colour
    d.R = (E.R - S.R) / 1536 'where.ScaleWidth
    d.G = (E.G - S.G) / 1536 'where.ScaleWidth
    d.B = (E.B - S.B) / 1536 'where.ScaleWidth
Dim c As Colour
c.R = S.R: c.G = S.G: c.B = S.B
Dim xG As Integer
For xG = 0 To 1536 'where.ScaleWidth
    lakesurf.SetForeColor RGB(c.R, c.G, c.B)
    lakesurf.DrawLine 0, xG, 2048, xG
    c.R = c.R + d.R
    c.G = c.G + d.G
    c.B = c.B + d.B
Next xG
End Sub
Sub Draw_Level()
Dim RetVal As Long
Dim rBlok As RECT
rBlok.Top = 0
rBlok.Bottom = 32
Dim X As Integer, Y As Integer
For X = 0 To 63
    For Y = 0 To 47
        If Floor(X, Y) <> 0 Then
        rBlok.Left = Floor(X, Y) * 32
        rBlok.Right = rBlok.Left + 32
        RetVal = lakesurf.BltFast(X * 32, Y * 32, Bloksurf, rBlok, DDBLTFAST_SRCCOLORKEY)
        End If
    Next Y
Next X
End Sub
Sub End_Level()
    levelnum = levelnum + 1
    Load_Level (levelnum)
    Draw_Gradient
    Draw_Level
End Sub
Public Function GetTextColour() As String
Select Case UCase(txtColour)
        Case "BLACK"
            GetTextColour = vbBlack
        Case "BLUE"
            GetTextColour = vbBlue
        Case "GREEN"
            GetTextColour = vbGreen
        Case "GREY"
            GetTextColour = "vbgrey"
        Case "RED"
            GetTextColour = vbRed
        Case "WHITE"
            GetTextColour = vbWhite
        Case "YELLOW"
            GetTextColour = vbYellow
End Select
End Function
Sub Init()
'    On Local Error GoTo errOut
    Dim file As String
    Set dd = dx.DirectDrawCreate("")
    Me.Show
    'indicate that we dont need to change display depth
    Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX Or DDSCL_EXCLUSIVE)
    Call dd.SetDisplayMode(640, 480, 24, 0, DDSDM_DEFAULT)

    'get the screen surface and create a back buffer too
    ddsd1.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
    ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
    ddsd1.lBackBufferCount = 1
    Set primary = dd.CreateSurface(ddsd1)
    'Get the backbuffer
    Dim caps As DDSCAPS2
    caps.lCaps = DDSCAPS_BACKBUFFER
    Set backbuffer = primary.GetAttachedSurface(caps)
    backbuffer.GetSurfaceDesc ddsd4

    'Create DrawableSurface class form backbuffer
    backbuffer.SetFontTransparency True
    backbuffer.SetForeColor vbGreen
    levelnum = 0
    ' init the surfaces
    InitSurfaces
    End_Level
    '~~~~~DIRECT INPUT~~~~~
    Set di = dx.DirectInputCreate()
    Set diDEV = di.CreateDevice("GUID_SysKeyboard")
    diDEV.SetCommonDataFormat DIFORMAT_KEYBOARD
    diDEV.SetCooperativeLevel Me.hWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
    diDEV.Acquire
    '~~~~~END INPUT~~~~~
    binit = True
    brunning = True
    Do While brunning
        Check_Keys
        Center_Screen
        blt
        DoEvents
    Loop
errOut:
    EndIt
End Sub
Sub InitSurfaces()
    Set lakesurf = Nothing
    Set Bloksurf = Nothing
    FindMediaDir "Dirt.bmp"
    'load the bitmap into a surface - lake
    ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    ddsd2.lWidth = 2048
    ddsd2.lHeight = 1536
    Set lakesurf = dd.CreateSurface(ddsd2)

    ddsd3.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    ddsd3.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    ddsd3.lWidth = 320
    ddsd3.lHeight = 32
    Set Bloksurf = dd.CreateSurfaceFromFile("Dirt.bmp", ddsd3)
    ddsd5.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    ddsd5.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    ddsd5.lWidth = 320
    ddsd5.lHeight = 32
    Set FruitSurf = dd.CreateSurfaceFromFile("Fruit.bmp", ddsd5)
    'use black for transparent color key which is on
    'the source bitmap -> use src keying
    Dim key As DDCOLORKEY
    key.low = 0
    key.high = 0
    Bloksurf.SetColorKey DDCKEY_SRCBLT, key
    FruitSurf.SetColorKey DDCKEY_SRCBLT, key
End Sub
Sub blt()
    On Local Error GoTo errOut
    If binit = False Then Exit Sub
    Dim ddrval As Long
    Static i As Integer
    Dim rBack As RECT
    Dim rLake As RECT
    Dim rSprite As RECT
    Dim rSprite2 As RECT
    Dim rPrim As RECT
    Dim rFruit As RECT
    Static a As Single
    Static X As Single
    Static Y As Single
    Static t As Single
    Static t2 As Single
    Static tLast As Single
    Static fps As Single
    ' this will keep us from trying to blt in case we lose the surfaces (alt-tab)
    bRestore = False
    Do Until ExModeActive
        DoEvents
        bRestore = True
    Loop
    ' if we lost and got back the surfaces, then restore them
    DoEvents
    If bRestore Then
        bRestore = False
        dd.RestoreAllSurfaces
        InitSurfaces ' must init the surfaces again if they we're lost
    End If
    'get the area of the screen where our window is
    rBack.Bottom = ddsd4.lHeight
    rBack.Right = ddsd4.lWidth
    'get the area of the bitmap we want ot blt
    rLake.Left = SBox.X
    rLake.Top = SBox.Y
    rLake.Bottom = SBox.Y + 480 'ddsd2.lHeight
    rLake.Right = SBox.X + 640 'ddsd2.lWidth
    'blt to the backbuffer from our  surface to
    'the screen surface such that our bitmap
    'appears over the window
    ddrval = backbuffer.BltFast(0, 0, lakesurf, rLake, DDBLTFAST_WAIT)
    'DRAW FRUIT
    rFruit.Top = 0
    rFruit.Bottom = 32
    rFruit.Left = 0
    rFruit.Right = 32
    ddrval = backbuffer.BltFast((P1.X * 32), (P1.Y * 32), FruitSurf, rFruit, DDBLTFAST_WAIT) ', DDBLTFAST_SRCCOLORKEY)
    'Calculate the frame rate
    If i = 30 Then
        If tLast <> 0 Then fps = 30 / (Timer - tLast)
        tLast = Timer
        i = 0
    End If
    i = i + 1
    Dim TXTc As String
    TXTc = GetTextColour()
    If TXTc = "vbgrey" Then
    backbuffer.SetForeColor RGB(128, 128, 128)
    Else
    backbuffer.SetForeColor TXTc
    End If
    If ShowInfo = True Then
    Call backbuffer.DrawText(10, 10, "-----INFORMATION-----", False)
    Call backbuffer.DrawText(10, 25, "LevelName: " & LevelName, False)
    Call backbuffer.DrawText(10, 40, "Level Number: " & levelnum, False)
    Call backbuffer.DrawText(10, 55, "Creator: " & Creator, False)
    Call backbuffer.DrawText(10, 70, "Points: " & Points, False)
    End If
    If ShowDebug = True Then
    Call backbuffer.DrawText(10, 85, "-----DEBUG-----", False)
    Call backbuffer.DrawText(10, 100, "Resolution: 640x480", False)
    Call backbuffer.DrawText(10, 115, "Colour Depth: 16bit", False)
    Call backbuffer.DrawText(10, 130, "Frames Per Second: " + Format$(fps, "#.0"), False)
    Call backbuffer.DrawText(10, 145, "Player X=" & P1.X & " (" & (P1.X * 32) & ") Player Y=" & P1.Y & " (" & (P1.Y * 32) & ")", False)
    Call backbuffer.DrawText(10, 160, "SBox.X=" & SBox.X & "  SBox.Y=" & SBox.Y, False)
    Call backbuffer.DrawText(10, 175, "Press Escape to Exit", False)
    End If
    'flip the back buffer to the screen
    primary.Flip Nothing, DDFLIP_WAIT
errOut:
End Sub
Sub EndIt()
    Call dd.RestoreDisplayMode
    Call dd.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
    End
End Sub
Sub Load_Level(levelnum As Integer)
Dim Filename As String
Filename = App.Path & "\levels\" & levelnum & ".FW2"
Dim FileToBeLoaded As String
Dim TheLineThatIsScrewed As String
Dim IntD1 As Integer, IntD2 As Integer
Dim X2 As Integer, Y2 As Integer
Open Filename For Input As #2
Input #2, FileToBeLoaded
Close #2
IntD1 = InStr(1, FileToBeLoaded, Chr$(13))
IntD2 = InStr(IntD1 + 1, FileToBeLoaded, Chr$(13))
TheLineThatIsScrewed = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
LevelName = Right(TheLineThatIsScrewed, Len(TheLineThatIsScrewed) - 1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
Creator = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
Theme = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
txtColour = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
Password = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
GStart.R = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
GStart.G = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
GStart.B = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
GEnd.R = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
GEnd.G = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
GEnd.B = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
For X2 = 0 To 63
For Y2 = 0 To 47
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
Floor(X2, Y2) = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
Next Y2
Next X2
For X2 = 0 To 63
For Y2 = 0 To 47
IntD1 = IntD2 + 1
IntD2 = InStr(IntD1, FileToBeLoaded, Chr$(13))
Value(X2, Y2) = Mid$(FileToBeLoaded, IntD1, IntD2 - IntD1)
Next Y2
Next X2
End Sub
Private Sub Form_Load()
    Init
End Sub
Private Sub Form_Paint()
    blt
End Sub
Function ExModeActive() As Boolean
    Dim TestCoopRes As Long
    TestCoopRes = dd.TestCooperativeLevel
    If (TestCoopRes = DD_OK) Then
        ExModeActive = True
    Else
        ExModeActive = False
    End If
End Function
Sub FindMediaDir(sFile As String)
    On Local Error Resume Next
    If Dir$(sFile) <> "" Then Exit Sub
    If Mid$(App.Path, 2, 1) = ":" Then
        ChDrive Mid$(App.Path, 1, 1)
    End If
    ChDir App.Path
    If Dir$(sFile) = "" Then
        ChDir "..\media"
    End If
    If Dir$(sFile) = "" Then
        ChDir "..\..\media"
    End If
End Sub