ddraw.bas

VB编写的RPG游戏演示,适合VB游戏初学者的参考。

                rectSource.Right = rectSource.Right - ((intX + TILE_WIDTH) - SCREEN_WIDTH)
            End If
            If intY < 0 Then
                rectSource.Top = rectSource.Top - intY
                intY = 0
            ElseIf intY + TILE_HEIGHT > SCREEN_HEIGHT Then
                rectSource.Bottom = rectSource.Bottom - ((intY + TILE_HEIGHT) - SCREEN_HEIGHT)
            End If
            'Blit it!
            msurfMain.BltFast intX, intY, msurfTiles, rectSource, DDBLTFAST_WAIT
        Next j
    Next i

End Sub

Private Sub LoadFramingBuffers()

Dim i As Integer
Dim j As Integer
Dim intX As Integer
Dim intY As Integer
Dim rectSource As RECT

    'Load the left buffer
    For i = -1 To 0
        For j = 0 To SCREEN_HEIGHT \ TILE_HEIGHT
            intX = i * TILE_WIDTH + TILE_WIDTH \ 2
            intY = j * TILE_HEIGHT
            With rectSource
                .Top = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intRow * TILE_HEIGHT
                .Bottom = .Top + TILE_HEIGHT
                .Left = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intColumn * TILE_WIDTH
                .Right = .Left + TILE_WIDTH
            End With
            If intX < 0 Then
                rectSource.Left = rectSource.Left - intX
                intX = 0
            ElseIf intX + TILE_WIDTH > TILE_WIDTH Then
                rectSource.Right = rectSource.Right - ((intX + TILE_WIDTH) - TILE_WIDTH)
            End If
            If intY < 0 Then
                rectSource.Top = rectSource.Top - intY
                intY = 0
            ElseIf intY + TILE_HEIGHT > SCREEN_HEIGHT Then
                rectSource.Bottom = rectSource.Bottom - ((intY + TILE_HEIGHT) - SCREEN_HEIGHT)
            End If
            msurfLeftBuff.BltFast intX, intY, msurfTiles, rectSource, DDBLTFAST_WAIT
        Next j
    Next i
    
    'Load the right buffer
    For i = SCREEN_WIDTH \ TILE_WIDTH To SCREEN_WIDTH \ TILE_WIDTH + 1
        For j = 0 To SCREEN_HEIGHT \ TILE_HEIGHT
            intX = i * TILE_WIDTH - TILE_WIDTH \ 2 - SCREEN_WIDTH
            intY = j * TILE_HEIGHT
            With rectSource
                .Top = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intRow * TILE_HEIGHT
                .Bottom = .Top + TILE_HEIGHT
                .Left = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intColumn * TILE_WIDTH
                .Right = .Left + TILE_WIDTH
            End With
            If intX < 0 Then
                rectSource.Left = rectSource.Left - intX
                intX = 0
            ElseIf intX + TILE_WIDTH > TILE_WIDTH Then
                rectSource.Right = rectSource.Right - ((intX + TILE_WIDTH) - TILE_WIDTH)
            End If
            If intY < 0 Then
                rectSource.Top = rectSource.Top - intY
                intY = 0
            ElseIf intY + TILE_HEIGHT > SCREEN_HEIGHT Then
                rectSource.Bottom = rectSource.Bottom - ((intY + TILE_HEIGHT) - SCREEN_HEIGHT)
            End If
            msurfRightBuff.BltFast intX, intY, msurfTiles, rectSource, DDBLTFAST_WAIT
        Next j
    Next i
    
    'Load the top buffer
    For i = 0 To SCREEN_WIDTH \ TILE_WIDTH + 1
        j = -1
        intX = i * TILE_WIDTH - TILE_WIDTH \ 2
        intY = 0
        With rectSource
            .Top = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intRow * TILE_HEIGHT
            .Bottom = .Top + TILE_HEIGHT
            .Left = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intColumn * TILE_WIDTH
            .Right = .Left + TILE_WIDTH
        End With
        If intX < 0 Then
            rectSource.Left = rectSource.Left - intX
            intX = 0
        ElseIf intX + TILE_WIDTH > SCREEN_WIDTH Then
            rectSource.Right = rectSource.Right - ((intX + TILE_WIDTH) - SCREEN_WIDTH)
        End If
        msurfTopBuff.BltFast intX, intY, msurfTiles, rectSource, DDBLTFAST_WAIT
    Next i
    
    'Load the bottom buffer
    For i = 0 To SCREEN_WIDTH \ TILE_WIDTH + 1
        j = SCREEN_HEIGHT \ TILE_HEIGHT
        intX = i * TILE_WIDTH - TILE_WIDTH \ 2
        intY = 0
        With rectSource
            .Top = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intRow * TILE_HEIGHT
            .Bottom = .Top + TILE_HEIGHT
            .Left = gudtMap(i + gudtCharacter(gintCenter).intXTile - SCREEN_WIDTH \ TILE_WIDTH \ 2, j + gudtCharacter(gintCenter).intYTile - SCREEN_HEIGHT \ TILE_HEIGHT \ 2).intColumn * TILE_WIDTH
            .Right = .Left + TILE_WIDTH
        End With
        If intX < 0 Then
            rectSource.Left = rectSource.Left - intX
            intX = 0
        ElseIf intX + TILE_WIDTH > SCREEN_WIDTH Then
            rectSource.Right = rectSource.Right - ((intX + TILE_WIDTH) - SCREEN_WIDTH)
        End If
        msurfBottomBuff.BltFast intX, intY, msurfTiles, rectSource, DDBLTFAST_WAIT
    Next i

End Sub

Public Function ConvToSignedValue(lngValue As Long) As Integer

    'Cheezy method for converting to signed integer
    If lngValue <= 32767 Then
        ConvToSignedValue = CInt(lngValue)
        Exit Function
    End If
    
    ConvToSignedValue = CInt(lngValue - 65535)

End Function

Public Function ConvToUnSignedValue(intValue As Integer) As Long

    'Cheezy method for converting to unsigned integer
    If intValue >= 0 Then
        ConvToUnSignedValue = intValue
        Exit Function
    End If
    
    ConvToUnSignedValue = intValue + 65535

End Function

Public Sub SetGamma(intRed As Integer, intGreen As Integer, intBlue As Integer)

Dim i As Integer

    'Alter the gamma ramp to the percent given by comparing to original state
    'A value of zero ("0") for intRed, intGreen, or intBlue will result in the
    'gamma level being set back to the original levels. Anything ABOVE zero will
    'fade towards FULL colour, anything below zero will fade towards NO colour
    For i = 0 To 255
        If intRed < 0 Then mudtGammaRamp.red(i) = ConvToSignedValue(ConvToUnSignedValue(mudtOriginalRamp.red(i)) * (100 - Abs(intRed)) / 100)
        If intRed = 0 Then mudtGammaRamp.red(i) = mudtOriginalRamp.red(i)
        If intRed > 0 Then mudtGammaRamp.red(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(mudtOriginalRamp.red(i))) * (100 - intRed) / 100))
        If intGreen < 0 Then mudtGammaRamp.green(i) = ConvToSignedValue(ConvToUnSignedValue(mudtOriginalRamp.green(i)) * (100 - Abs(intGreen)) / 100)
        If intGreen = 0 Then mudtGammaRamp.green(i) = mudtOriginalRamp.green(i)
        If intGreen > 0 Then mudtGammaRamp.green(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(mudtOriginalRamp.green(i))) * (100 - intGreen) / 100))
        If intBlue < 0 Then mudtGammaRamp.blue(i) = ConvToSignedValue(ConvToUnSignedValue(mudtOriginalRamp.blue(i)) * (100 - Abs(intBlue)) / 100)
        If intBlue = 0 Then mudtGammaRamp.blue(i) = mudtOriginalRamp.blue(i)
        If intBlue > 0 Then mudtGammaRamp.blue(i) = ConvToSignedValue(65535 - ((65535 - ConvToUnSignedValue(mudtOriginalRamp.blue(i))) * (100 - intBlue) / 100))
    Next
    mobjGammaControler.SetGammaRamp DDSGR_DEFAULT, mudtGammaRamp

End Sub

Private 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()

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

    'Kill the surfaces
    'FILL IN THE REST!!!
    Set msurfTiles = Nothing
    Set msurfBack = Nothing
    Set msurfFront = Nothing
    
    'Kill directdraw
    Set mdd = Nothing

End Sub

Public Sub FadeIn()

Dim i As Integer

    'Gamma fade in!
    DisplayTiles                            'Display the appropriate tiles
    DisplaySprites                          'Display sprites (incl. NPC's and character)
    DisplaySpeech                           'Display NPC speech if appropriate
    FPS                                     'Count/display the FPS
    If LostSurfaces Then LoadSurfaces       'Check for and restore lost surfaces
    msurfFront.Flip Nothing, DDFLIP_WAIT    'Flip!!!
    If mblnGamma Then
        For i = -99 To 0 Step 1
            SlowDown
            mintRedVal = i
            mintGreenVal = i
            mintBlueVal = i
            SetGamma mintRedVal, mintGreenVal, mintBlueVal
        Next
    End If
    mblnFadeIn = False

End Sub

Public Sub FadeOut()

Dim i As Integer

    'Gamma fade out!
    If mblnGamma Then
        For i = 0 To -99 Step -1
            SlowDown
            mintRedVal = i
            mintGreenVal = i
            mintBlueVal = i
            SetGamma mintRedVal, mintGreenVal, mintBlueVal
        Next
    End If

End Sub

Private Sub SlowDown()

Dim lngTickStore As Long

    'Delay the effect somewhat
    lngTickStore = gdx.TickCount()
    Do While lngTickStore + FADE_DELAY_MS > gdx.TickCount()
        DoEvents
    Loop

End Sub

Public Sub FlipFrame()
    
    'Flip!!
    msurfFront.Flip Nothing, DDFLIP_WAIT

End Sub

Public Sub CheckFade()

    'Check for fade in
    If mblnFadeIn Then FadeIn
    
End Sub