frmdemox.frm

由于这是本人近一年前初学vb时的作品

    Dim lOffsetY As Integer
    Dim iDestTile As Integer
    Dim iAnim As Integer 'character movement animation frame
    
    '// start of main drawing routine //
    Do
        'allow change of direction only after full movement cycle
        If miStep = 0 Then
            If mbPendingLeft Then
                miDirX = -1
                meFaceDir = dirLeft
            ElseIf mbPendingRight Then
                miDirX = 1
                meFaceDir = dirRight
            ElseIf mbPendingUp Then
                miDirY = -1
                meFaceDir = dirUp
            ElseIf mbPendingDown Then
                miDirY = 1
                meFaceDir = dirDown
            End If
            
            'check destination tile behavior
            iDestTile = Map1(miBaseX + 8 + miDirX, miBaseY + 6 + miDirY)
            If TileBehavior(iDestTile) = "" Or TileBehavior(iDestTile) = "NoGo" Then
                miDirX = 0
                miDirY = 0
            End If
            'other tile behaviors could be checked here
            '(doors, chests, ladders, etc.)
        End If
        
        
        If miDirX Or miDirY Then
            miStep = miStep + 1
            If miStep = 1 Then
                
                'these BaseX,Y checks aren't necessary if map
                'is bordered by NoGo tiles
                miBaseX = miBaseX + miDirX
                If miBaseX < -8 Then
                    miDirX = 0
                    miBaseX = -8
                End If
                If miBaseX > MapSizeX - 9 Then
                    miDirX = 0
                    miBaseX = MapSizeX - 9
                End If
            
                miBaseY = miBaseY + miDirY
                If miBaseY < -6 Then
                    miDirY = 0
                    miBaseY = -6
                End If
                If miBaseY > MapSizeY - 7 Then
                    miDirY = 0
                    miBaseY = MapSizeY - 7
                End If
            End If
        Else
            miStep = 0
        End If
        
        'calculate visible screen offset from floor buffer
        '8 steps of 4 pixels = move char one 32 pixel tile
        lOffsetX = miStep * 4 * miDirX
        lOffsetY = miStep * 4 * miDirY
        
        'tile source surface area to blt
        rcBig.Left = lOffsetX + 32
        rcBig.Top = lOffsetY + 32
        rcBig.Right = lOffsetX + 639 + 32
        rcBig.Bottom = lOffsetY + 479 + 32
        'Debug.Print lOffsetX, lOffsetY
        
        'chars source surface area to blt
        'pick the next animation frame for the
        'direction the character is moving
        iAnim = miStep Mod 4 'four char animation frames
        With rcChar
            .Left = iAnim * 48
            .Right = .Left + 48
            'each direction's animation is on a different
            'row in the Char buffer
            .Top = (meFaceDir - 1) * 48
            .Bottom = .Top + 48
        End With
        
        'draw floor to hidden back buffer
        ddsBack1.BltFast 0, 0, ddsFloor, rcBig, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
        'draw main char to back buffer at center of screen
        ddsBack1.BltFast 280, 210, ddsChars, rcChar, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
        
        If mbShowStats Then ShowStatBox
        
        'copy fully-drawn back buffer to primary surface
        'done in one fell swoop to insure
        'flicker-free animation
        rcBig.Top = 0
        rcBig.Left = 0
        rcBig.Bottom = 479
        rcBig.Right = 639
        ddsPrimary.BltFast 0, 0, ddsBack1, rcBig, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
        
        If miStep >= 8 Then
            'character has just finished taking one full
            'step (moved 32 pixels)
        
            'take visible portion of map and
            'center it on the floor buffer
            'and update the outer edge of the
            'floor buffer with new tile images
            'in the direction of movement
            
            If miDirX = 1 Then  'finished moving right
                rcBig.Top = 0
                rcBig.Bottom = 64 + 479 + 64
                rcBig.Left = 32
                rcBig.Right = 64 + 639 + 64
                ddsFloor.BltFast 0, 0, ddsFloor, rcBig, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
                DrawZBuffer dirRight
                
            ElseIf miDirX = -1 Then 'finished moving left
                rcBig.Top = 0
                rcBig.Bottom = 64 + 479 + 64
                rcBig.Left = 0
                rcBig.Right = 64 + 639 + 32
                ddsFloor.BltFast 32, 0, ddsFloor, rcBig, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
                DrawZBuffer dirLeft
                
            ElseIf miDirY = 1 Then 'finished moving down
                rcBig.Top = 32
                rcBig.Bottom = 64 + 479 + 64
                rcBig.Left = 0
                rcBig.Right = 64 + 639 + 64
                ddsFloor.BltFast 0, 0, ddsFloor, rcBig, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
                DrawZBuffer dirDown
                
            ElseIf miDirY = -1 Then 'finished moving up
                rcBig.Top = 0
                rcBig.Bottom = 64 + 479 + 32
                rcBig.Left = 0
                rcBig.Right = 64 + 639 + 64
                ddsFloor.BltFast 0, 32, ddsFloor, rcBig, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
                DrawZBuffer dirUp
                            
            End If
                    
            miDirX = 0
            miDirY = 0
            miStep = 0  'reset character step counter
            bDrawing = False
            DoEvents
        End If
        
        bDrawing = False
        DoEvents
    Loop While mbRunning = True
    Unload Me
    Exit Sub
    
ErrorTimer:
    MsgBox Err.Description, , "tmrMain_Timer ERROR"
    Unload Me
End Sub

Private Sub DrawZBuffer(DrawSide As EDirection)
    
    '// updates the floor scrolling buffer //
    'new floor tiles are drawn on the outer
    'edge of the buffer in the direction of
    'character movement
    
    On Error GoTo ErrorDrawZ
    Dim iMapX As Integer
    Dim iMapY As Integer
    Dim x As Long
    Dim y As Long
    Dim iTile As Integer
    Dim hdcFloor As Long
    Dim rcTile As RECT
    
    'Call ddsFloor.GetDC(hdcFloor)
    
    'default to blank tile square
    rcTile.Top = 0
    rcTile.Bottom = 32
    
    Select Case DrawSide
        Case dirRight
            'right side buffer
            For y = -2 To 16
                iMapX = miBaseX + 21
                iMapY = miBaseY + y
                rcTile.Left = 0  'default to blank tile
                rcTile.Right = 32
                'make sure map location is within map boundaries
                If iMapX >= 0 And iMapX < MapSizeX And iMapY >= 0 And iMapY < MapSizeY Then
                    iTile = Map1(iMapX, iMapY)
                    If iTile >= 0 Then
                        'use faster BltFast routine later!!!!
                        'imlFloorTiles.ListImages(iTile).Draw hdcFloor, (64 + 639 + 32) * TwipsX, (y + 2) * 32 * TwipsY
                        rcTile.Left = iTile * 32
                        rcTile.Right = (iTile * 32) + 32
                    End If
                End If
                ddsFloor.BltFast 735, (y + 2) * 32, ddsTiles, rcTile, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
            Next y
        
        Case dirLeft
            'left side buffer
            For y = -2 To 16
                iMapX = miBaseX - 2
                iMapY = miBaseY + y
                rcTile.Left = 0  'default to blank tile
                rcTile.Right = 32
                'make sure map location is within map boundaries
                If iMapX >= 0 And iMapX < MapSizeX And iMapY >= 0 And iMapY < MapSizeY Then
                    iTile = Map1(iMapX, iMapY)
                    If iTile >= 0 Then
                        'use faster BltFast routine later!!!!
                        'imlFloorTiles.ListImages(iTile).Draw hdcFloor, 0, (y + 2) * 32 * TwipsY
                        rcTile.Left = iTile * 32
                        rcTile.Right = (iTile * 32) + 32
                    End If
                End If
                ddsFloor.BltFast 0, (y + 2) * 32, ddsTiles, rcTile, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
            Next y
            
        Case dirDown
            For x = -2 To 21
                iMapX = miBaseX + x
                iMapY = miBaseY + 16
                rcTile.Left = 0  'default to blank tile
                rcTile.Right = 32
                'make sure map location is within map boundaries
                If iMapX >= 0 And iMapX < MapSizeX And iMapY >= 0 And iMapY < MapSizeY Then
                    iTile = Map1(iMapX, iMapY)
                    If iTile >= 0 Then
                        'use faster BltFast routine later!!!!
                        'imlFloorTiles.ListImages(iTile).Draw hdcFloor, (x + 2) * 32 * TwipsX, (64 + 479 + 32) * TwipsY
                        rcTile.Left = iTile * 32
                        rcTile.Right = (iTile * 32) + 32
                    End If
                End If
                ddsFloor.BltFast (x + 2) * 32, 64 + 479 + 32, ddsTiles, rcTile, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
            Next x
            
        Case dirUp
            For x = -2 To 21
                iMapX = miBaseX + x
                iMapY = miBaseY - 2
                rcTile.Left = 0  'default to blank tile
                rcTile.Right = 32
                'make sure map location is within map boundaries
                If iMapX >= 0 And iMapX < MapSizeX And iMapY >= 0 And iMapY < MapSizeY Then
                    iTile = Map1(iMapX, iMapY)
                    If iTile >= 0 Then
                        'use faster BltFast routine later!!!!
                        'imlFloorTiles.ListImages(iTile).Draw hdcFloor, (x + 2) * 32 * TwipsX, 0
                        rcTile.Left = iTile * 32
                        rcTile.Right = (iTile * 32) + 32
                    End If
                End If
                ddsFloor.BltFast (x + 2) * 32, 0, ddsTiles, rcTile, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
            Next x
            
    End Select
    'Call ddsFloor.ReleaseDC(hdcFloor)
    Exit Sub
    
ErrorDrawZ:
    MsgBox Err.Description, , "DrawZBuffer ERROR"
    'Call ddsFloor.ReleaseDC(hdcFloor)
    Unload Me
End Sub

Private Sub FillTileBuffer()
    
    '// loads the tileset pictures into the DD Tiles buffer //
    
    On Error GoTo ErrorFillTile
    Dim i As Integer
    Dim iMaxTiles As Integer
    Dim hdcTiles As Long
    
    'first tile (#0) is always a blank square
    
    Call ddsTiles.GetDC(hdcTiles)
    iMaxTiles = imlFloorTiles.ListImages.Count
    For i = 1 To iMaxTiles
        imlFloorTiles.ListImages(i).Draw hdcTiles, i * 32 * TwipsX, 0
    Next i
    Call ddsTiles.ReleaseDC(hdcTiles)
    Exit Sub
    
ErrorFillTile:
    MsgBox Err.Description, , "FillTileBuffer ERROR"
    Call ddsFloor.ReleaseDC(hdcTiles)
    Unload Me
End Sub


Private Sub FillFloorBuffer(ByVal VisibleBaseX As Long, ByVal VisibleBaseY As Long)
    
    'sets up the floor buffer with tile images for the
    'current map area
    
    On Error GoTo ErrorFillFloor
    Dim x As Long
    Dim y As Long
    Dim iMapX As Integer
    Dim iMapY As Integer
    Dim iTile As Integer
    Dim iMaxTile As Integer
    Dim rcTile As RECT
    
    iMaxTile = imlFloorTiles.ListImages.Count
    TwipsX = Screen.TwipsPerPixelX
    TwipsY = Screen.TwipsPerPixelY
    
    rcTile.Top = 0
    rcTile.Bottom = 32
    
    For x = -2 To 21
        For y = -2 To 16
            iMapX = VisibleBaseX + x
            iMapY = VisibleBaseY + y
            rcTile.Left = 0  'default to blank tile
            rcTile.Right = 32
            If iMapX >= 0 And iMapX < MapSizeX And iMapY >= 0 And iMapY < MapSizeY Then
                iTile = Map1(iMapX, iMapY)
                If iTile > 0 And iTile <= iMaxTile Then
                    rcTile.Left = iTile * 32
                    rcTile.Right = iTile * 32 + 32
                     'imlFloorTiles.ListImages(iTile).Draw hdcFloor, (x + 2) * 32 * TwipsX, (y + 2) * 32 * TwipsY
                End If
            End If
            ddsFloor.BltFast (x + 2) * 32, (y + 2) * 32, ddsTiles, rcTile, DDBLTFAST_WAIT Or DDBLTFAST_NOCOLORKEY
        Next y
    Next x
    Exit Sub
    
ErrorFillFloor:
    MsgBox Err.Description, , "FillFloorBuffer ERROR"
    Unload Me
End Sub

Private Sub ShowStatBox()
    
    'displays a blue box with various character/game stats
    'in the lower left-hand corner of the screen
    
    On Error GoTo ErrorShowStat
    Dim hdcBack As Long ' Back buffer's DC
    Dim lpString As String
    Dim hndPen As Long
    Dim hndBrush As Long
    Dim oldpen As Long
    Dim oldbrush As Long
    Dim di As Long
    Dim rcBox As RECT

    
    ' DON'T BREAK THE CODE ON THE FOLLOWING LINES!!
    ' Get the DC of the back buffer
    Call ddsBack1.GetDC(hdcBack)
    
    ' You can break the code from here on!
    
    ' Set the back color and text color
    Call SetBkColor(hdcBack, vbBlue)
    Call SetTextColor(hdcBack, vbWhite)
    
    'create a white pen for drawing the box border
    hndPen = CreatePen(PS_SOLID, 2, vbWhite)
    If hndPen <> 0 Then oldpen = SelectObject(hdcBack, hndPen)
    
    With rcBox
        .Top = 360
        .Left = 20
        .Bottom = 470
        .Right = 200
        
        'draw stats box outline
        Rectangle hdcBack, .Left - 1, .Top - 1, .Right + 1, .Bottom + 1
        'restore original pen
        If oldpen <> 0 Then di = SelectObject(hdcBack, oldpen)
        
        'create blue brush to fill box with
        hndBrush = CreateSolidBrush(vbBlue)
        If hndBrush <> 0 Then oldbrush = SelectObject(hdcBack, hndBrush)
        'draw blue box
        FillRect hdcBack, rcBox, hndPen
        'restore old brush
        If oldbrush <> 0 Then di = SelectObject(hdcBack, oldbrush)
        
        'print stats information
        lpString = "Studly's Stats"
        Call TextOut(hdcBack, .Left + 8, .Top + 8, lpString, Len(lpString))
        lpString = "HP:  0128 / 0256"
        Call TextOut(hdcBack, .Left + 8, .Top + 32, lpString, Len(lpString))
        lpString = "X: " & Str$(miBaseX + 8) & "   Y: " & Str$(miBaseY + 6)
        Call TextOut(hdcBack, .Left + 8, .Top + 56, lpString, Len(lpString))
    End With
    
    ' delete drawing objects and release the DC's, very important!!
    If hndPen Then di = DeleteObject(hndPen)
    If hndBrush Then di = DeleteObject(hndBrush)
    Call ddsBack1.ReleaseDC(hdcBack)
    Exit Sub
    
ErrorShowStat:
    MsgBox Err.Description, , "ShowStatBox ERROR"
    If hndPen Then di = DeleteObject(hndPen)
    If hndBrush Then di = DeleteObject(hndBrush)
    Call ddsBack1.ReleaseDC(hdcBack)
    Unload Me
End Sub