ddraw.bas

vb6的一个RPG源码

Attribute VB_Name = "DDraw"
Option Explicit
'DirectX variables
Dim mdd As DirectDraw7
Dim msurfFront As DirectDrawSurface7
Dim msurfBack As DirectDrawSurface7
Dim ElSprite As DirectDrawSurface7
Dim msurfTiles As DirectDrawSurface7
Dim TalkBox As DirectDrawSurface7
Dim Itemz As DirectDrawSurface7
Const SPEECH_WIDTH = 640
Const SPEECH_HEIGHT = 120
Const SPEECH_START_HEIGHT = 32
Const SPEECH_START_WIDTH = 15
Const SPEECH_LINE_SPACING = 20
Dim mlngFrameTime As Long                   'How long since last frame?
Dim mlngTimer As Long                       'How long since last FPS count update?
Dim mintFPSCounter As Integer               'Our FPS counter
Dim mintFPS As Integer                      'Our FPS storage variable
Dim mrectScreen As RECT
Public SaleLoop As Byte
Public PointerX As Integer
Public PointerY As Integer

Public Sub DrawTiles()
Dim i As Integer
Dim j As Integer
Dim rectTile As RECT
Dim bytTileNum As Tilez
Dim bytTileNum2 As Tilez
Dim intx As Integer
Dim inty As Integer
Dim intItem As Byte
    'Draw the tiles according to the map array
    For i = 0 To CInt(SCREEN_WIDTH / TILE_WIDTH)
        For j = 0 To CInt(SCREEN_HEIGHT / TILE_HEIGHT)
            'Calc X,Y coords for this tile's placement
            intx = i * TILE_WIDTH - mintX Mod TILE_WIDTH
            inty = j * TILE_HEIGHT - mintY Mod TILE_HEIGHT
            bytTileNum = GetTileG(intx, inty)
            bytTileNum2 = GetTileF(intx, inty)
            intItem = GetItem(intx, inty)
            GetRect bytTileNum, intx, inty, rectTile
            msurfBack.BltFast intx, inty, msurfTiles, rectTile, DDBLTFAST_WAIT
            If bytTileNum2.X <> 0 Or bytTileNum2.Y <> 0 Then
            intx = i * TILE_WIDTH - mintX Mod TILE_WIDTH
            inty = j * TILE_HEIGHT - mintY Mod TILE_HEIGHT
            GetRect bytTileNum2, intx, inty, rectTile
            msurfBack.BltFast intx, inty, msurfTiles, rectTile, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
            End If
            If intItem > 0 Then
            intx = i * TILE_WIDTH - mintX Mod TILE_WIDTH
            inty = j * TILE_HEIGHT - mintY Mod TILE_HEIGHT
            intItem = DaItems(intItem - 1).GrhIndex
            'Get the rectangle
            GetItemRect intItem, intx, inty, rectTile
            'Blit the tile
            msurfBack.BltFast intx, inty, Itemz, rectTile, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
            End If
            Next j
    Next i

End Sub

Private Function GetTileG(intTileX As Integer, intTileY As Integer) As Tilez

    'Return the value returned by the map array for the given tile
    GetTileG = mbytMap((intTileX + TILE_WIDTH \ 2 + mintX - SCREEN_WIDTH \ 2) \ TILE_WIDTH, (intTileY + TILE_HEIGHT \ 2 + mintY - SCREEN_HEIGHT \ 2) \ TILE_HEIGHT).TileNumber.Ground

End Function

Private Function GetTileF(intTileX As Integer, intTileY As Integer) As Tilez

    'Return the value returned by the map array for the given tile
    GetTileF = mbytMap((intTileX + TILE_WIDTH \ 2 + mintX - SCREEN_WIDTH \ 2) \ TILE_WIDTH, (intTileY + TILE_HEIGHT \ 2 + mintY - SCREEN_HEIGHT \ 2) \ TILE_HEIGHT).TileNumber.Floor

End Function
Private Function GetTileS(X As Integer, Y As Integer) As Tilez

    'Return the value returned by the map array for the given tile
    GetTileS = mbytMap(X, Y).TileNumber.Sky

End Function
Private Sub GetRect(bytTileNumber As Tilez, ByRef intTileX As Integer, ByRef intTileY As Integer, ByRef rectTile As RECT)

    'Calc rect
    With rectTile
        .Left = bytTileNumber.X * TILE_WIDTH
        .Right = .Left + TILE_WIDTH
        .Top = bytTileNumber.Y * TILE_HEIGHT
        .Bottom = .Top + TILE_HEIGHT
    
    'Clip rect
        
        'If this tile is off the left side of the screen...
        If intTileX < 0 Then
            .Left = .Left - intTileX
            intTileX = 0
        End If
        'If this tile is off the top of the screen...
        If intTileY < 0 Then
            .Top = .Top - intTileY
            intTileY = 0
        End If
        'If this tile is off the right side of the screen...
        If intTileX + TILE_WIDTH > SCREEN_WIDTH Then .Right = .Right + (SCREEN_WIDTH - (intTileX + TILE_WIDTH))
        'If this tile is off the bottom of the screen...
        If intTileY + TILE_HEIGHT > SCREEN_HEIGHT Then .Bottom = .Bottom + (SCREEN_HEIGHT - (intTileY + TILE_HEIGHT))
    End With

End Sub

Public Sub MoveScreen()
msurfBack.BltColorFill mrectScreen, 0
    'Move screen
    If Walking = South Then
        If DudeCoord.Y < 8 Then GoTo MoveIt:
    mintY = mintY + SCROLL_SPEED
    GoTo MoveIt:
    End If
    If Walking = North Then
        If DudeCoord.Y > 41 Then GoTo MoveIt:
    mintY = mintY - SCROLL_SPEED
    GoTo MoveIt:
    End If
    If Walking = West Then
        If DudeCoord.X > 39 Then GoTo MoveIt:
    mintX = mintX - SCROLL_SPEED
    GoTo MoveIt:
    End If
    If Walking = East Then
        If DudeCoord.X < 10 Then GoTo MoveIt:
    mintX = mintX + SCROLL_SPEED
    GoTo MoveIt:
    End If
'Ensure we don't go off the edge, and move NPC Accordingly if so.
MoveIt:
    If mintX < SCREEN_WIDTH \ 2 Then
    mintX = SCREEN_WIDTH \ 2
    End If
    If mintX > UBound(mbytMap, 1) * TILE_WIDTH - SCREEN_WIDTH \ 2 Then
    mintX = UBound(mbytMap, 1) * TILE_WIDTH - SCREEN_WIDTH \ 2
    End If
    If mintY < SCREEN_HEIGHT \ 2 Then
    mintY = SCREEN_HEIGHT \ 2
    End If
    If mintY > UBound(mbytMap, 2) * TILE_HEIGHT - SCREEN_HEIGHT \ 2 Then
    mintY = UBound(mbytMap, 2) * TILE_HEIGHT - SCREEN_HEIGHT \ 2
    End If
End Sub

Public Sub FPS()
    'Count FPS
    If mlngTimer + 1000 <= Gdx.TickCount Then
        mlngTimer = Gdx.TickCount
        mintFPS = mintFPSCounter + 1
        mintFPSCounter = 0
    Else
        mintFPSCounter = mintFPSCounter + 1
    End If
    'Display FPS, text, and possibly NPC Speech

    msurfBack.DrawText 0, 0, "Megalodon's RPG Engine", False
    msurfBack.DrawText 0, 20, "FPS: " & mintFPS, False
    msurfBack.DrawText 0, 40, "X= " & DudeCoord.X & "Y= " & DudeCoord.Y, False
    If TradeNPC = 1 Then DisplayNPCQuery
    If SayNPC Then DisplaySpeech
    If TradeNPC = 2 Then DrawTradeMenu
    If TradeNPC = 3 Then DrawTradeMenu
    If DispInventMenu = True Then DrawInventMenu
    DrawHealth
    msurfFront.Flip Nothing, DDFLIP_WAIT
    End Sub
Public Sub LoadSurfaces()
Dim CKey As DDCOLORKEY
Dim ddsdGeneric As DDSURFACEDESC2
Dim tLocked As Long
Dim TempRct As RECT
    'Set up generic surface description
    ddsdGeneric.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    ddsdGeneric.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
    'Load our tileset
    ddsdGeneric.lHeight = 352
    ddsdGeneric.lWidth = 768
    Set msurfTiles = mdd.CreateSurfaceFromFile(App.Path & "\tileset.bmp", ddsdGeneric)
    ddsdGeneric.lHeight = 768
    ddsdGeneric.lWidth = 256
    Set ElSprite = mdd.CreateSurfaceFromFile(App.Path & "\Pat.bmp", ddsdGeneric)
    With TempRct
        .Bottom = 384
        .Top = 0
        .Left = 0
        .Right = 192
    End With
    ElSprite.Lock TempRct, ddsdGeneric, DDLOCK_NOSYSLOCK, frmMain.hWnd
    tLocked = ElSprite.GetLockedPixel(0, 0)
    ElSprite.Unlock TempRct
    ddsdGeneric.lHeight = 885
    ddsdGeneric.lWidth = 640
    Set TalkBox = mdd.CreateSurfaceFromFile(App.Path & "\ChatBox.bmp", ddsdGeneric)
    ddsdGeneric.lHeight = 32
    ddsdGeneric.lWidth = 800
    Set Itemz = mdd.CreateSurfaceFromFile(App.Path & "\Itemz.bmp", ddsdGeneric)
CKey.low = tLocked
CKey.high = tLocked
msurfTiles.SetColorKey DDCKEY_SRCBLT, CKey
ElSprite.SetColorKey DDCKEY_SRCBLT, CKey
TalkBox.SetColorKey DDCKEY_SRCBLT, CKey
Itemz.SetColorKey DDCKEY_SRCBLT, CKey
End Sub

Public Function ExclusiveMode() As Boolean

Dim lngTestExMode As Long
    
    'This function tests if we're still in exclusive mode
    lngTestExMode = mdd.TestCooperativeLevel
    
    If (lngTestExMode = DD_OK) Then
        ExclusiveMode = True
    Else
        ExclusiveMode = False
    End If
    
End Function

Public Function LostSurfaces() As Boolean

    'This function will tell if we should reload our bitmaps or not
    LostSurfaces = False
    Do Until ExclusiveMode
        DoEvents
        LostSurfaces = True
    Loop
    
    'If we did lose our bitmaps, restore the surfaces and return 'true'
    DoEvents
    If LostSurfaces Then
        mdd.RestoreAllSurfaces
    End If
    
End Function

Public Sub Terminate()
    'Terminate the render loop
    mblnRunning = False

    'Restore resolution
    mdd.RestoreDisplayMode
    mdd.SetCooperativeLevel 0, DDSCL_NORMAL

    'Kill the surfaces
    Set Itemz = Nothing
    Set TalkBox = Nothing
    Set msurfTiles = Nothing
    Set ElSprite = Nothing
    Set msurfBack = Nothing
    Set msurfFront = Nothing
    'Kill directdraw
    Set mdd = Nothing
    'Kill DirectX
    Set Gdx = Nothing
End Sub



Public Sub Init()
Dim ddsdMain As DDSURFACEDESC2
Dim ddsdFlip As DDSURFACEDESC2    'Show the main form
    frmMain.Show

    'Initialize DirectDraw
    Set mdd = Gdx.DirectDrawCreate("")
    
    'Set the cooperative level (Fullscreen exclusive)
    mdd.SetCooperativeLevel frmMain.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE
    
    'Set the resolution
    mdd.SetDisplayMode SCREEN_WIDTH, SCREEN_HEIGHT, SCREEN_BITDEPTH, 0, DDSDM_DEFAULT

    'Describe the flipping chain architecture we'd like to use
    ddsdMain.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
    ddsdMain.lBackBufferCount = 1
    ddsdMain.ddsCaps.lCaps = DDSCAPS_COMPLEX Or DDSCAPS_FLIP Or DDSCAPS_PRIMARYSURFACE
    
    'Create the primary surface
    Set msurfFront = mdd.CreateSurface(ddsdMain)
    
    'Create the backbuffer
    ddsdFlip.ddsCaps.lCaps = DDSCAPS_BACKBUFFER
    Set msurfBack = msurfFront.GetAttachedSurface(ddsdFlip.ddsCaps)
    
    'Set the text colour for the backbuffer
    msurfBack.SetForeColor vbWhite
    msurfBack.SetFontTransparency True

    'Create our screen-sized rectangle
    mrectScreen.Bottom = SCREEN_HEIGHT
    mrectScreen.Right = SCREEN_WIDTH
YCharOffSet = 7
XCharOffSet = 10
PointerX = 275
PointerY = 113
SaleLoop = 0
    LoadSurfaces
End Sub
Private Sub DisplaySpeech()
Dim SrcRect As RECT
Dim strTemp As String
Dim strOne As String
Dim strTwo As String
Dim strThree As String
Dim strFour As String
    With SrcRect
    .Left = 0
    .Right = 640
    .Top = 0
    .Bottom = 100
    End With
    msurfBack.BltFast 0, 380, TalkBox, SrcRect, DDBLTFAST_SRCCOLORKEY Or DDBLTFAST_WAIT
    'Extract NPC Name and Text
    strTemp = NPCTalk
    If NPCFirst Then
        If strTemp <> "" Then TempName = Left(strTemp, InStr(1, strTemp, ":") - 1)
        strTemp = Right(strTemp, Len(strTemp) - InStr(1, strTemp, ":"))
        End If
    If strTemp <> "" Then strOne = Left(strTemp, InStr(1, strTemp, "|") - 1)
    If strTemp <> "" Then strTemp = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "|"))
    If strTemp <> "" Then strTwo = Left(strTemp, InStr(1, strTemp, "|") - 1)
    If strTemp <> "" Then strTemp = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "|"))
    If strTemp <> "" Then strThree = Left(strTemp, InStr(1, strTemp, "|") - 1)
    If strTemp <> "" Then strTemp = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "|"))
    If strTemp <> "" Then strFour = Left(strTemp, InStr(1, strTemp, "|") - 1)
    If strTemp <> "" Then
    strTemp = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "|"))
    Else
    strTemp = ""
    End If
    strOne = TempName & ": " & strOne
    'Ensure that these don't overlap the next "page" of text, and display them
    If InStr(1, strOne, "~") = 0 And strOne <> "" Then
        msurfBack.DrawText SPEECH_START_WIDTH, 480 - SPEECH_HEIGHT + SPEECH_START_HEIGHT, strOne, False
        If InStr(1, strTwo, "~") = 0 And strTwo <> "" Then
            msurfBack.DrawText SPEECH_START_WIDTH + 55, 480 - SPEECH_HEIGHT + SPEECH_START_HEIGHT + SPEECH_LINE_SPACING, strTwo, False
            If InStr(1, strThree, "~") = 0 And strThree <> "" Then
                msurfBack.DrawText SPEECH_START_WIDTH + 55, 480 - SPEECH_HEIGHT + SPEECH_START_HEIGHT + 2 * SPEECH_LINE_SPACING, strThree, False
                If InStr(1, strFour, "~") = 0 And strFour <> "" Then msurfBack.DrawText SPEECH_START_WIDTH + 55, 480 - SPEECH_HEIGHT + SPEECH_START_HEIGHT + 3 * SPEECH_LINE_SPACING, strFour, False
            End If
        End If
    End If
    NPCNext = strTemp
End Sub
Public Sub DrawNPC()
Dim i As Integer
Dim j As Integer
Dim rectTile As RECT
Dim intx As Integer
Dim inty As Integer
Dim blnNPC As Boolean
Dim TempNPCX As Integer
Dim TempNPCY As Integer

    'Draw the tiles according to the map array
    For i = 0 To CInt(SCREEN_WIDTH / TILE_WIDTH)