frmmain.frm

利用VB的图片框实现屏幕的滚动如可以用来创建一些动画图形等。其实对于上面的问题我们也可 以利用图片框来巧妙地解决。

    Dim TmpX As Long, TmpY As Long
    Dim CellX As Long, CellY As Long
    Select Case Tanks(i).Dir
    Case DUp
        TmpX = Tanks(i).X
        TmpY = Tanks(i).Y - Speeds(Tanks(i).Speed)
        CellX = ToCellX(TmpX + HalfCellSize)
        CellY = ToCellY(TmpY)
    Case DDown
        TmpX = Tanks(i).X
        TmpY = Tanks(i).Y + Speeds(Tanks(i).Speed)
        CellX = ToCellX(TmpX + HalfCellSize)
        CellY = ToCellY(TmpY + CellSize - 1)
    Case DLeft
        TmpX = Tanks(i).X - Speeds(Tanks(i).Speed)
        TmpY = Tanks(i).Y
        CellX = ToCellX(TmpX)
        CellY = ToCellY(TmpY + HalfCellSize)
    Case DRight
        TmpX = Tanks(i).X + Speeds(Tanks(i).Speed)
        TmpY = Tanks(i).Y
        CellX = ToCellX(TmpX + CellSize - 1)
        CellY = ToCellY(TmpY + HalfCellSize)
    End Select
    If CellX < 0 Or CellY < 0 Or CellX > CellXMax Or CellY > CellYMax Then Exit Sub
    If (Cells(CellX, CellY) > CGround And Cells(CellX, CellY) < CRepair) Or _
        (Objs(CellX, CellY) > 0 And Objs(CellX, CellY) <> i + 1 And Objs(CellX, CellY) < FirstShell) Then
        Exit Sub
    End If
    If i = 0 And Cells(CellX, CellY) > CGround Then
        GetBox Cells(CellX, CellY)
        ChangeCell CellX, CellY, CGround
    End If
    Dim OldCellX As Long, OldCellY As Long
    OldCellX = ToCellX(Tanks(i).X + HalfCellSize)
    OldCellY = ToCellY(Tanks(i).Y + HalfCellSize)
    If Objs(OldCellX, OldCellY) = i + 1 Then
        Objs(OldCellX, OldCellY) = 0
    End If
    EraseTank i
    Tanks(i).X = TmpX
    Tanks(i).Y = TmpY
    Dim NewCellX As Long, NewCellY As Long
    NewCellX = ToCellX(Tanks(i).X + HalfCellSize)
    NewCellY = ToCellY(Tanks(i).Y + HalfCellSize)
    Objs(NewCellX, NewCellY) = i + 1
End Sub

' 坦克转向
Private Sub TurnTank(ByVal i As Long, ByVal Dir As enuDir)
    EraseTank i
    Tanks(i).Dir = Dir
    If i = 0 Then
        Tanks(i).X = Int((Tanks(i).X + HalfCellSize) / CellSize) * CellSize
        Tanks(i).Y = Int((Tanks(i).Y + HalfCellSize) / CellSize) * CellSize
    End If
End Sub

' 坦克受损
Private Sub DamageTank(ByVal i As Long, ByVal Power As Long)
    Dim Damage As Long
    Damage = Power - Shields(Tanks(i).Shield)
    Tanks(i).Strength = Tanks(i).Strength - Damage
    If Tanks(i).Strength <= 0 Then
        DestroyTank i
    End If
    If i = 0 Then prgStrength.Value = Tanks(0).Strength
End Sub

' 坦克被摧毁
Private Sub DestroyTank(ByVal i As Long)
    Tanks(i).Strength = 0
    Dim CellX As Long, CellY As Long
    CellX = ToCellX(Tanks(i).X + HalfCellSize)
    CellY = ToCellY(Tanks(i).Y + HalfCellSize)
    If Objs(CellX, CellY) = i + 1 Then Objs(CellX, CellY) = 0
    EraseTank i
    If i = 0 Then
        If TankCount > 0 Then
            TankCount = TankCount - 1
            lblTankCount = "坦克 X " & TankCount
            CreateTank
        Else
            MsgBox "SORRY, YOU LOSE!"
            End
        End If
    Else
        If EnemyCount > 0 Then
            CreateEnemy i
            DrawTank i
            EnemyCount = EnemyCount - 1
            lblEnemyCount = EnemyCount
        ElseIf EnemyCount > 1 - ActiveMax Then
            EnemyCount = EnemyCount - 1
            lblEnemyCount = 0
        Else
            tmrWon.Enabled = True
        End If
    End If
End Sub

' ________________________________________________________________________________
'
' 炮弹及相关处理函数
' ________________________________________________________________________________
'
' 生成炮弹
Private Sub CreateShell(ByVal i As Long, ByVal Enemy As Boolean)
    Dim DestX As Long, DestY As Long
    Select Case Tanks(i).Dir
    Case DUp
        DestX = Tanks(i).X
        DestY = Tanks(i).Y - HalfCellSize
    Case DDown
        DestX = Tanks(i).X
        DestY = Tanks(i).Y + HalfCellSize
    Case DLeft
        DestX = Tanks(i).X - HalfCellSize
        DestY = Tanks(i).Y
    Case DRight
        DestX = Tanks(i).X + HalfCellSize
        DestY = Tanks(i).Y
    End Select
    If DestX < 0 Or DestY < 0 Or DestX > CellSizeXCellXMax Or DestY > CellSizeXCellYMax Then
        Exit Sub
    End If
    Dim j As Long
    For j = i * SPTMax To i * SPTMax + Rates(Tanks(i).Rate) - 1
        If Shells(j).Power = 0 Then
            Shells(j).X = DestX
            Shells(j).Y = DestY
            Shells(j).Dir = Tanks(i).Dir
            Shells(j).Power = Powers(Tanks(i).Power)
            Shells(j).Enemy = Enemy
            Exit Sub
        End If
    Next
End Sub

' 炮弹移动
Private Sub DoShell(ByVal i As Long)
    Dim DestX As Long, DestY As Long
    Dim CellX As Long, CellY As Long
    Select Case Shells(i).Dir
    Case DUp
        DestX = Shells(i).X
        DestY = Shells(i).Y - ShellSpeed
    Case DDown
        DestX = Shells(i).X
        DestY = Shells(i).Y + ShellSpeed
    Case DLeft
        DestX = Shells(i).X - ShellSpeed
        DestY = Shells(i).Y
    Case DRight
        DestX = Shells(i).X + ShellSpeed
        DestY = Shells(i).Y
    End Select
    If DestX < 0 Or DestY < 0 Or DestX > CellSizeXCellXMax Or DestY > CellSizeXCellYMax Then
        DestroyShell i, False
        Exit Sub
    End If
    CellX = ToCellX(DestX + HalfCellSize)
    CellY = ToCellY(DestY + HalfCellSize)
    If Objs(CellX, CellY) > 0 Then
        If Objs(CellX, CellY) = 1 Then
            If Shells(i).Enemy Then
                DamageTank 0, Shells(i).Power
                DestroyShell i
                Exit Sub
            End If
        ElseIf Objs(CellX, CellY) < FirstShell Then
            If Not Shells(i).Enemy Then
                DamageTank Objs(CellX, CellY) - 1, Shells(i).Power
                DestroyShell i
                Exit Sub
            End If
        Else
            Dim j As Long
            j = Objs(CellX, CellY) - FirstShell
            If Shells(i).Enemy Xor Shells(j).Enemy Then
                DestroyShell i
                DestroyShell j
                Exit Sub
            End If
        End If
    End If
    Select Case Cells(CellX, CellY)
    Case CArmor
        DestroyShell i
        Exit Sub
    Case CBrick
        ChangeCell CellX, CellY, CClod
        DestroyShell i
        Exit Sub
    Case CBox
        ChangeCell CellX, CellY, Int(Rnd * (CStop - CEmpty + 1)) + CEmpty
        DestroyShell i
        Exit Sub
    Case CClod, CEmpty
        ChangeCell CellX, CellY, CGround
        DestroyShell i
        Exit Sub
    Case Else
    End Select
    Dim OldCellX As Long, OldCellY As Long
    OldCellX = ToCellX(Shells(i).X + HalfCellSize)
    OldCellY = ToCellY(Shells(i).Y + HalfCellSize)
    If Objs(OldCellX, OldCellY) = FirstShell + i Then
        Objs(OldCellX, OldCellY) = 0
    End If
    EraseShell i
    Shells(i).X = DestX
    Shells(i).Y = DestY
    If Objs(CellX, CellY) = 0 Then
        Objs(CellX, CellY) = FirstShell + i
    End If
End Sub

' 炮弹被摧毁
Private Sub DestroyShell(ByVal i As Long, Optional ByVal Blaze As Boolean = True)
    If Blaze Then
        CreateBlaze Shells(i).X, Shells(i).Y
        sndPlaySound "Boom.wav", SND_ASYNC
    Else
        EraseShell i
    End If
    Shells(i).Power = 0
    Dim CellX As Long, CellY As Long
    CellX = ToCellX(Shells(i).X + HalfCellSize)
    CellY = ToCellY(Shells(i).Y + HalfCellSize)
    If Objs(CellX, CellY) = FirstShell + i Then Objs(CellX, CellY) = 0
End Sub

' ________________________________________________________________________________
'
' 爆炸效果及相关函数
' ________________________________________________________________________________
'
' 生成爆炸效果
Private Sub CreateBlaze(ByVal X As Long, ByVal Y As Long)
    Dim i As Long
    For i = 0 To BlazeMax
        If Blazes(i).Step = 0 Then
            Blazes(i).Step = 1
            Blazes(i).X = X
            Blazes(i).Y = Y
            Exit Sub
        End If
    Next
End Sub

' 爆炸效果进行
Private Sub DoBlaze(ByVal i As Long)
    Blazes(i).Step = Blazes(i).Step + BlazeStep
    If Blazes(i).Step > BlazeStepMax Then
        Blazes(i).Step = 0
        EraseBlaze i
    End If
End Sub

' ________________________________________________________________________________
'
' 地图格相关函数
' ________________________________________________________________________________
'
' 改变地图格
Private Sub ChangeCell(ByVal CellX As Long, ByVal CellY As Long, ByVal DestCell As enuCell)
    Cells(CellX, CellY) = DestCell
    DrawBack CellX, CellY
    DrawCell CellX, CellY
End Sub

' 获取奖励物品
Private Sub GetBox(ByVal Box As enuCell)
    Dim i As Long
    Select Case Box
    Case CRepair
        Tanks(0).Strength = Tanks(0).Strength + StrengthMax \ 2
        If Tanks(0).Strength > StrengthMax Then Tanks(0).Strength = StrengthMax
        prgStrength.Value = Tanks(0).Strength
    Case CFull
        Tanks(0).Strength = StrengthMax
        prgStrength.Value = Tanks(0).Strength
    Case CPower
        If Tanks(0).Power < 2 Then
            Tanks(0).Power = Tanks(0).Power + 1
            prgPower.Value = Tanks(0).Power
        End If
    Case CShield
        If Tanks(0).Shield < 2 Then
            Tanks(0).Shield = Tanks(0).Shield + 1
            prgShield.Value = Tanks(0).Shield
        End If
    Case CSpeed
        If Tanks(0).Speed < 2 Then
            Tanks(0).Speed = Tanks(0).Speed + 1
            prgSpeed.Value = Tanks(0).Speed
        End If
    Case CRate
        If Tanks(0).Rate < 2 Then
            Tanks(0).Rate = Tanks(0).Rate + 1
            prgRate.Value = Tanks(0).Rate
        End If
    Case CLife
        TankCount = TankCount + 1
        lblTankCount = "坦克 X " & TankCount
    Case CLevel
        If Tanks(0).Power < 2 Then
            Tanks(0).Power = Tanks(0).Power + 1
            prgPower.Value = Tanks(0).Power
        End If
        If Tanks(0).Shield < 2 Then
            Tanks(0).Shield = Tanks(0).Shield + 1
            prgShield.Value = Tanks(0).Shield
        End If
        If Tanks(0).Speed < 2 Then
            Tanks(0).Speed = Tanks(0).Speed + 1
            prgSpeed.Value = Tanks(0).Speed
        End If
        If Tanks(0).Rate < 2 Then
            Tanks(0).Rate = Tanks(0).Rate + 1
            prgRate.Value = Tanks(0).Rate
        End If
    Case CBlock
        For i = 1 To ActiveMax
            If Tanks(i).Strength > 0 Then
                DamageTank i, Powers(Tanks(0).Power)
                CreateBlaze Tanks(i).X, Tanks(i).Y
            End If
        Next
    Case CStop
        PauseTime = PauseTime + PauseTimePlus
    Case Else
    End Select
End Sub

' ________________________________________________________________________________
'
' 图象处理函数
' ________________________________________________________________________________
'
' 绘制地图格
Private Sub DrawCell(ByVal CellX As Long, ByVal CellY As Long)
    BitBlt picMain.hDC, CellX * CellSize, CellY * CellSize, CellSize, CellSize, picData.hDC, Cells(CellX, CellY) * CellSize, CellSizeX3, vbSrcCopy
End Sub

' 更新背景
Private Sub DrawBack(ByVal CellX As Long, ByVal CellY As Long)
    BitBlt picBack.hDC, CellX * CellSize, CellY * CellSize, CellSize, CellSize, picData.hDC, Cells(CellX, CellY) * CellSize, CellSizeX3, vbSrcCopy
End Sub

' 绘制坦克
Private Sub DrawTank(ByVal i As Long)
    Dim xSrc As Long
    xSrc = Tanks(i).Image * CellSizeX4 + Tanks(i).Dir * CellSize
    BitBlt picMain.hDC, Tanks(i).X, Tanks(i).Y, CellSize, CellSize, picData.hDC, xSrc, CellSize, vbSrcAnd
    BitBlt picMain.hDC, Tanks(i).X, Tanks(i).Y, CellSize, CellSize, picData.hDC, xSrc, 0, vbSrcPaint
End Sub

' 绘制炮弹
Private Sub DrawShell(ByVal i As Long)
    BitBlt picMain.hDC, Shells(i).X, Shells(i).Y, CellSize, CellSize, picData.hDC, CellSize, CellSizeX2, vbSrcAnd
    BitBlt picMain.hDC, Shells(i).X, Shells(i).Y, CellSize, CellSize, picData.hDC, 0, CellSizeX2, vbSrcPaint
End Sub

' 绘制爆炸效果
Private Sub DrawBlaze(ByVal i As Long)
    Dim X As Long
    X = Int(Blazes(i).Step) * CellSizeX2
    BitBlt picMain.hDC, Blazes(i).X, Blazes(i).Y, CellSize, CellSize, picData.hDC, X - CellSize, CellSizeX2, vbSrcAnd
    BitBlt picMain.hDC, Blazes(i).X, Blazes(i).Y, CellSize, CellSize, picData.hDC, X - CellSizeX2, CellSizeX2, vbSrcPaint
End Sub

' 擦除坦克
Private Sub EraseTank(ByVal i As Long)
    BitBlt picMain.hDC, Tanks(i).X, Tanks(i).Y, CellSize, CellSize, picBack.hDC, Tanks(i).X, Tanks(i).Y, vbSrcCopy
End Sub

' 擦除炮弹
Private Sub EraseShell(ByVal i As Long)
    BitBlt picMain.hDC, Shells(i).X, Shells(i).Y, CellSize, CellSize, picBack.hDC, Shells(i).X, Shells(i).Y, vbSrcCopy
End Sub

' 擦除爆炸效果
Private Sub EraseBlaze(ByVal i As Long)
    BitBlt picMain.hDC, Blazes(i).X, Blazes(i).Y, CellSize, CellSize, picBack.hDC, Blazes(i).X, Blazes(i).Y, vbSrcCopy
End Sub

' ________________________________________________________________________________
'
' 其它函数
' ________________________________________________________________________________
'
' 转换象素点坐标为格子坐标
Private Function ToCellX(ByVal X As Long) As Long
    ToCellX = Int(X / CellSize)
End Function

' 转换象素点坐标为格子坐标
Private Function ToCellY(ByVal Y As Long) As Long
    ToCellY = Int(Y / CellSize)
End Function