| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛 | 
登录
注册
用户控制面板
搜索
道具
风格
短消息
论坛展区
帮助
编程论坛 → 开发语言 → 『 VB6论坛 』 → 用VB6实现俄罗斯方块游戏(游戏编程入门教程)&追爱
我的收件箱(0)
欢迎加入我们，一同切磋技术
用户名：   
 
密　码：  
共有 3544 人关注过本帖， 2 人收藏
标题：用VB6实现俄罗斯方块游戏(游戏编程入门教程)&追爱
只看楼主 加入收藏
方寸
Rank: 1
等　级：新手上路
帖　子：6
专家分：0
注　册：2011-5-18
结帖率：0
楼主
收藏(2)
 问题点数：0 回复次数：3 
用VB6实现俄罗斯方块游戏(游戏编程入门教程)&追爱
俄罗斯方块作为一个经典游戏被广泛实现于各种平台
对于新手而言用来游戏编程入门是一个不错的选择

本教程将教你如何用VB6实现一个俄罗斯方块游戏

代码量仅有10kb多

图片如下
图片附件: 游客没有浏览图片的权限，请 登录 或 注册


代码如下
程序代码：
Dim g_bStart As Integer  '游戏是否已开始
Dim g_bStop As Integer '游戏是否已暂停
Dim g_SquareType As Integer '标识当前方块类型
Dim g_NextSquareType As Integer '标识下一个方块类型
Dim g_SquarePosX As Integer, g_SquarePosY As Integer '当前方块位置
Dim g_Square(3, 3) As Boolean '方块矩阵
Dim g_NextSquare(3, 3) As Boolean '下一个方块矩阵
Dim g_Site(11, 16) As Boolean '摆放地
Dim g_DrawPage As New StdPicture '游戏图像缓冲页面
Private Type SqrRange '方块矩阵最小范围
        x As Integer
        y As Integer
        ex As Integer
        ey As Integer
End Type
Dim SqrR As SqrRange

'方块类型
Const KIND1 = 0 '正方形
Const KIND2 = 1 '拐杖形
Const KIND3 = 2 '长条形
Const KIND4 = 3 '蛇形
Const KIND5 = 4 '山形
'方块大小
Const SQUARESIZE = 32 '方块大小


Private Sub Command2_Click()
    GameInit
End Sub

Private Sub Exit_Click()
    Unload MainForm
End Sub



Private Sub Explain_Click()
    MsgBox "为追爱而作"
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim tSqr(3, 3) As Integer '临时方块矩阵
    Dim x As Integer, y As Integer
    
    If Timer.Enabled = False Then GoTo EndKeyUp
    
    If KeyCode = vbKeyLeft And CanMove(g_SquarePosX - 1, g_SquarePosY) Then
        g_SquarePosX = g_SquarePosX - 1
        Draw
    ElseIf KeyCode = vbKeyRight And CanMove(g_SquarePosX + 1, g_SquarePosY) Then
        g_SquarePosX = g_SquarePosX + 1
        Draw
    ElseIf KeyCode = vbKeyDown And CanMove(g_SquarePosX, g_SquarePosY + 1) Then
        g_SquarePosY = g_SquarePosY + 1
        Draw
    ElseIf KeyCode = vbKeyUp Then
        If g_SquareType = KIND1 Then GoTo EndKeyUp
        '复制方块矩阵
        y = 0
        While y <= 3
            x = 0
            While x <= 3
                tSqr(x, y) = g_Square(x, y)
                x = x + 1
            Wend
            y = y + 1
        Wend
        ChangeSqr
        If Not CanMove(g_SquarePosX, g_SquarePosY) Then '如果变形后不可移动还原方块数组
            y = 0
            While y <= 3
                x = 0
                While x <= 3
                    g_Square(x, y) = tSqr(x, y)
                    x = x + 1
                Wend
                y = y + 1
            Wend
        End If
        Draw
    End If
EndKeyUp:
End Sub

Private Sub Form_Load()
'初始化程序状态
    g_bStart = False
    g_bStop = False
    MusicCheck.Value = 1
End Sub

Private Sub Form_Paint()
    Draw
End Sub

Private Sub MusicCheck_Click()
    If MusicCheck.Value = 1 Then
        WMP.Controls.play
    Else
        WMP.Controls.Stop
    End If
End Sub



Private Sub Start_Click()
    If Not g_bStart Then
        
        GameInit

        Timer.Enabled = True
    End If
End Sub

Private Sub Stop_Click()
    If Timer.Enabled = True Then
        Timer.Enabled = False
    ElseIf Timer.Enabled = False Then
        Timer.Enabled = True
    End If
End Sub

Private Sub Timer_Timer()
    Dim x As Integer, y As Integer
    Dim i As Integer
    Dim SqrCount As Integer '一行方块计数
    Dim DelCount As Integer '消除行数计数，用来计算分数
    
    '消除方块
    DelCount = 0
    y = 15
    While y >= 1
        x = 0
        SqrCount = 0
        While x <= 10
            If g_Site(x, y) Then
                SqrCount = SqrCount + 1
            End If
            x = x + 1
        Wend
        If SqrCount = 11 Then '符合消除条件
            i = y
            While i >= 1
                x = 0
                While x <= 10
                    g_Site(x, i) = g_Site(x, i - 1)
                    x = x + 1
                Wend
                i = i - 1
            Wend
            DelCount = DelCount + 1
        End If
        y = y - 1
    Wend
    If DelCount = 1 Then
        Grades.Caption = Str(Val(Grades.Caption) + 5)
    ElseIf DelCount = 2 Then
        Grades.Caption = Str(Val(Grades.Caption) + 12)
    ElseIf DelCount > 2 Then
        Grades.Caption = Str(Val(Grades.Caption) + DelCount * 10)
    End If
    
    If CanMove(g_SquarePosX, g_SquarePosY + 1) Then
        g_SquarePosY = g_SquarePosY + 1 '方块下降一个单位
    Else '方块固化
        CalSqrRange
        y = g_SquarePosY + SqrR.y
        
        While y <= g_SquarePosY + 2
            x = g_SquarePosX + SqrR.x
            While x <= g_SquarePosX + 2 And x <= 10
                g_Site(x, y) = g_Site(x, y) Or g_Square(x - g_SquarePosX, y - g_SquarePosY)
                x = x + 1
            Wend
            y = y + 1
        Wend
        If g_SquarePosY + SqrR.y <= 1 Then
            MsgBox "抱歉，你输了!"
            Timer.Enabled = False
        Else
            y = 0
            While y <= 2
                x = 0
                While x <= 2
                    g_Square(x, y) = g_NextSquare(x, y)
                    x = x + 1
                Wend
                y = y + 1
            Wend
            g_SquarePosX = 4
            g_SquarePosY = 0
            ProduceNextSqr
        End If
    End If
  '  GamePage(1).Refresh
    Draw
    
  '  DrawSquare g_SquarePosX * SQUARESIZE, (g_SquarePosY - 2) * SQUARESIZE
End Sub

'绘制所有要绘制的对象
Sub Draw()
    Dim x As Integer, y As Integer

    GamePage(1).Refresh '清屏
    
    '绘制摆放地
    y = 0
    While y <= 15
        x = 0
        While x <= 10
            If g_Site(x, y) Then
                GamePage(1).PaintPicture ImgList.ListImages.Item(1).Picture, x * SQUARESIZE, (y - 2) * SQUARESIZE
            End If
            x = x + 1
        Wend
        y = y + 1
    Wend
    '绘制当前控制方块
    y = g_SquarePosY
    While y <= g_SquarePosY + 2
        x = g_SquarePosX
        While x <= g_SquarePosX + 2
            If g_Square(x - g_SquarePosX, y - g_SquarePosY) Then
                GamePage(1).PaintPicture ImgList.ListImages.Item(1).Picture, x * SQUARESIZE, (y - 2) * SQUARESIZE
            End If
            x = x + 1
        Wend
        y = y + 1
    Wend
    DrawNextSquare
End Sub

'游戏初始化
Sub GameInit()
    Dim x As Integer, y As Integer
    
    
    '清空摆放地
    y = 0
    While y <= 15
        x = 0
        While x <= 10
            g_Site(x, y) = 0
            x = x + 1
        Wend
        y = y + 1
    Wend
    
    ProduceNextSqr
    
    '产生第一个方块
    g_SquareType = Int(4 * Rnd)
    g_SquarePosX = 4
    g_SquarePosY = 0
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            g_Square(x, y) = g_NextSquare(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
    ProduceNextSqr
End Sub

'随机产生下一个方块
Sub ProduceNextSqr()
    Dim Kind As Integer
    Dim x As Integer, y As Integer

    '清空方块矩阵
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            g_NextSquare(x, y) = 0
            x = x + 1
        Wend
        y = y + 1
    Wend
    
    Kind = Int(Rnd * 4)
    
    If Kind = KIND1 Then '正方形
        g_NextSquare(0, 0) = True
        g_NextSquare(0, 1) = True
        g_NextSquare(1, 0) = True
        g_NextSquare(1, 1) = True
    ElseIf Kind = KIND2 Then '拐杖形
        g_NextSquare(0, 0) = True
        g_NextSquare(1, 0) = True
        g_NextSquare(0, 1) = True
        g_NextSquare(0, 2) = True
    ElseIf Kind = KIND3 Then '长条形
        g_NextSquare(0, 0) = True
        g_NextSquare(0, 1) = True
        g_NextSquare(0, 2) = True
    ElseIf Kind = KIND4 Then '蛇形
        g_NextSquare(0, 0) = True
        g_NextSquare(1, 0) = True
        g_NextSquare(1, 1) = True
        g_NextSquare(2, 1) = True
    ElseIf Kind = KIND5 Then '山形
        g_NextSquare(0, 1) = True
        g_NextSquare(1, 0) = True
        g_NextSquare(1, 1) = True
        g_NextSquare(2, 1) = True
    End If
    g_NextSquareType = Kind
End Sub

'方块矩阵翻转
Sub ChangeSqr()
    Dim x As Integer, y As Integer
    Dim Sqr(3, 3) As Boolean
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            Sqr(x, y) = g_Square(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
    Dim x2, y2
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            g_Square(y, 2 - x) = Sqr(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
End Sub

'检测当前控制方块是否能处于某一位置
Function CanMove(x As Integer, y As Integer) As Boolean
    Dim tx As Integer, ty As Integer
    Dim xe As Integer, ye As Integer
    
    '确定方块矩阵最小方形范围
    CalSqrRange

    If x + SqrR.x < 0 Then '左侧越界
        CanMove = False
        GoTo EndCanMove
    ElseIf x + SqrR.ex > 10 Then '右侧越界
        CanMove = False
        GoTo EndCanMove
    ElseIf y + SqrR.ey > 15 Then '下方越界
        CanMove = False
        GoTo EndCanMove
    End If
    
    '检测是否有方块冲突
    ty = y + SqrR.y
    While ty <= y + SqrR.ey
        tx = x + SqrR.x
        While tx <= x + SqrR.ex
            If g_Site(tx, ty) And g_Square(tx - x, ty - y) Then
                CanMove = False
                GoTo EndCanMove
            End If
            tx = tx + 1
        Wend
        ty = ty + 1
    Wend
    
    CanMove = True
EndCanMove:
End Function

'确定方块矩阵最小范围
Sub CalSqrRange() '
    '确定方块矩阵最小方形范围
    
    '横向扫描
    wy = 0
    While wy <= 2
        wx = 0
        While wx <= 2
            If g_Square(wx, wy) Then
                SqrR.y = wy
                GoTo Endy
            End If
            wx = wx + 1
        Wend
        wy = wy + 1
    Wend
Endy:
    '竖向扫描
    wx = 0
    While wx <= 2
        wy = 0
        While wy <= 2
            If g_Square(wx, wy) Then
                SqrR.x = wx
                GoTo Endx
            End If
            wy = wy + 1
        Wend
        wx = wx + 1
    Wend
Endx:
    '横向扫描
    wy = 2
    While wy >= 0
        wx = 0
        While wx <= 2
            If g_Square(wx, wy) Then
                SqrR.ey = wy
                GoTo Endey
            End If
            wx = wx + 1
        Wend
        wy = wy - 1
    Wend
Endey:
    '竖向扫描
    wx = 2
    While wx >= 0
        wy = 0
        While wy <= 2
            If g_Square(wx, wy) Then
                SqrR.ex = wx
                GoTo Endex
            End If
            wy = wy + 1
        Wend
        wx = wx - 1
    Wend
Endex:
End Sub

'绘制下一方块
Sub DrawNextSquare()
    Dim x As Integer, y As Integer
    
    GamePage(0).Refresh
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            If g_NextSquare(x, y) Then
                GamePage(0).PaintPicture ImgList.ListImages.Item(1).Picture, x * SQUARESIZE, y * SQUARESIZE
            End If
            x = x + 1
        Wend
        y = y + 1
    Wend
End Sub


代码附件含音乐较大上传不了在这里下载
fangcun.

[ 本帖最后由 方寸 于 2012-11-5 17:06 编辑 ]
收到的鲜花
  • 风吹过b 于 2012-11-05 21:48 送鲜花  20朵   附言：二楼的解释对新手特别好。
搜索更多相关主题的帖子: 游戏编程　俄罗斯方块　color　如何　
2012-11-05 17:04
方寸
Rank: 1
等　级：新手上路
帖　子：6
专家分：0
注　册：2011-5-18
第 2 楼
收藏
 得分:0 
如何标示一个方块

我们知道俄罗斯方块有不同的方块类型，而且，如何标示这些方块是一个问题

很容易想到的方法就是使用3*3的0-1数组，
比如标示正方形的0-1数组
1，1，0
1，1，0
0，0，0
(0)
标示拐杖形的0-1数组
1，1，0
0，1，0
0，1，0
(1)
而且这样标示的话有一个好处，只要翻转数组就可以得到换向后的方块
如对(1)翻转
0，0，0
1，1，1
1，0，0
可以看出这种翻转其实就是将行变为列
翻转代码如下
程序代码：
'方块矩阵翻转
Sub ChangeSqr()
    Dim x As Integer, y As Integer
    Dim Sqr(3, 3) As Boolean
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            Sqr(x, y) = g_Square(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
    Dim x2, y2
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            g_Square(y, 2 - x) = Sqr(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
End Sub


如前面所讲，方块使用3*3的0-1数组标示的，
那么绘制方块的过程就是遍历数组
如果g_Square(x,y)=1那么就绘制出小正方形，否则不绘制

程序代码：
'绘制下一方块
Sub DrawNextSquare()
    Dim x As Integer, y As Integer
    
    GamePage(0).Refresh
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            If g_NextSquare(x, y) Then
                GamePage(0).PaintPicture ImgList.ListImages.Item(1).Picture, x * SQUARESIZE, y * SQUARESIZE
            End If
            x = x + 1
        Wend
        y = y + 1
    Wend
End Sub


问题要来了，
虽然用0-1数组标示方块很好，但有一个问题是数组并没有被完全使用
如标示拐杖形的0-1数组
1，1，0
0，1，0
0，1，0
(1)
另外该数组翻转后为
0，0，0
1，1，1
1，0，0
(2)
可看到(1)的最后一列和(2)的第一行完全空出来了
这就造成如何判断方块是否碰到墙壁和已经固化方块的问题

对此我们可以计算出方块在0-1数组中的最小范围（构成方块的最小矩形）
然后在判断是加上相对位置
如(1)的最小范围
(0,0),(1,2)
(2)的最小范围
(0,1),(2,2)

计算代码如下
程序代码：
'确定方块矩阵最小范围
Sub CalSqrRange() '
    '确定方块矩阵最小方形范围
    
    '横向扫描
    wy = 0
    While wy <= 2
        wx = 0
        While wx <= 2
            If g_Square(wx, wy) Then
                SqrR.y = wy
                GoTo Endy
            End If
            wx = wx + 1
        Wend
        wy = wy + 1
    Wend
Endy:
    '竖向扫描
    wx = 0
    While wx <= 2
        wy = 0
        While wy <= 2
            If g_Square(wx, wy) Then
                SqrR.x = wx
                GoTo Endx
            End If
            wy = wy + 1
        Wend
        wx = wx + 1
    Wend
Endx:
    '横向扫描
    wy = 2
    While wy >= 0
        wx = 0
        While wx <= 2
            If g_Square(wx, wy) Then
                SqrR.ey = wy
                GoTo Endey
            End If
            wx = wx + 1
        Wend
        wy = wy - 1
    Wend
Endey:
    '竖向扫描
    wx = 2
    While wx >= 0
        wy = 0
        While wy <= 2
            If g_Square(wx, wy) Then
                SqrR.ex = wx
                GoTo Endex
            End If
            wy = wy + 1
        Wend
        wx = wx - 1
    Wend
Endex:
End Sub


然后是翻转数组实现方块的旋转
程序代码：
'方块矩阵翻转
Sub ChangeSqr()
    Dim x As Integer, y As Integer
    Dim Sqr(3, 3) As Boolean
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            Sqr(x, y) = g_Square(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
    Dim x2, y2
    
    y = 0
    While y <= 2
        x = 0
        While x <= 2
            g_Square(y, 2 - x) = Sqr(x, y)
            x = x + 1
        Wend
        y = y + 1
    Wend
    
End Sub


那么如何判断方块能否落入某一区域？

游戏使用g_Site的0-1数组标示已经固化的方块

对方块数组和g_Site相对位置的数组元素进行And(位与)操作
如果有一个结果为1，就说明不可以移入
代码如下
程序代码：
'检测当前控制方块是否能处于某一位置
Function CanMove(x As Integer, y As Integer) As Boolean
    Dim tx As Integer, ty As Integer
    Dim xe As Integer, ye As Integer
    
    '确定方块矩阵最小方形范围
    CalSqrRange

    If x + SqrR.x < 0 Then '左侧越界
        CanMove = False
        GoTo EndCanMove
    ElseIf x + SqrR.ex > 10 Then '右侧越界
        CanMove = False
        GoTo EndCanMove
    ElseIf y + SqrR.ey > 15 Then '下方越界
        CanMove = False
        GoTo EndCanMove
    End If
    
    '检测是否有方块冲突
    ty = y + SqrR.y
    While ty <= y + SqrR.ey
        tx = x + SqrR.x
        While tx <= x + SqrR.ex
            If g_Site(tx, ty) And g_Square(tx - x, ty - y) Then
                CanMove = False
                GoTo EndCanMove
            End If
            tx = tx + 1
        Wend
        ty = ty + 1
    Wend
    
    CanMove = True
EndCanMove:
End Function


到这里游戏实现已经很清晰了，
只要检测要移入的位置是否可移入，来移动方块

那么如何实现方块的自动下降呢？
用Timer控件，每隔一段时间方块的y坐标+1，
并检测下是否有可以消除的方块

代码如下
程序代码：
Private Sub Timer_Timer()
    Dim x As Integer, y As Integer
    Dim i As Integer
    Dim SqrCount As Integer '一行方块计数
    Dim DelCount As Integer '消除行数计数，用来计算分数
    
    '消除方块
    DelCount = 0
    y = 15
    While y >= 1
        x = 0
        SqrCount = 0
        While x <= 10
            If g_Site(x, y) Then
                SqrCount = SqrCount + 1
            End If
            x = x + 1
        Wend
        If SqrCount = 11 Then '符合消除条件
            i = y
            While i >= 1
                x = 0
                While x <= 10
                    g_Site(x, i) = g_Site(x, i - 1)
                    x = x + 1
                Wend
                i = i - 1
            Wend
            DelCount = DelCount + 1
        End If
        y = y - 1
    Wend
    If DelCount = 1 Then
        Grades.Caption = Str(Val(Grades.Caption) + 5)
    ElseIf DelCount = 2 Then
        Grades.Caption = Str(Val(Grades.Caption) + 12)
    ElseIf DelCount > 2 Then
        Grades.Caption = Str(Val(Grades.Caption) + DelCount * 10)
    End If
    
    If CanMove(g_SquarePosX, g_SquarePosY + 1) Then
        g_SquarePosY = g_SquarePosY + 1 '方块下降一个单位
    Else '方块固化
        CalSqrRange
        y = g_SquarePosY + SqrR.y
        
        While y <= g_SquarePosY + 2
            x = g_SquarePosX + SqrR.x
            While x <= g_SquarePosX + 2 And x <= 10
                g_Site(x, y) = g_Site(x, y) Or g_Square(x - g_SquarePosX, y - g_SquarePosY)
                x = x + 1
            Wend
            y = y + 1
        Wend
        If g_SquarePosY + SqrR.y <= 1 Then
            MsgBox "抱歉，你输了!"
            Timer.Enabled = False
        Else
            y = 0
            While y <= 2
                x = 0
                While x <= 2
                    g_Square(x, y) = g_NextSquare(x, y)
                    x = x + 1
                Wend
                y = y + 1
            Wend
            g_SquarePosX = 4
            g_SquarePosY = 0
            ProduceNextSqr
        End If
    End If
  '  GamePage(1).Refresh
    Draw
    
  '  DrawSquare g_SquarePosX * SQUARESIZE, (g_SquarePosY - 2) * SQUARESIZE
End Sub


最后此贴为追爱而发，希望觉得还不错的朋友
为了向一个女孩证明自己决定寻找一千个陌生人祝福，
希望你能留下你的祝福
谢谢
地址：
http://blog.

[ 本帖最后由 方寸 于 2012-11-5 17:52 编辑 ]
收到的鲜花
  • Artless 于 2012-11-06 12:48 送鲜花  21朵   附言：好文章
2012-11-05 17:16
Rexfield
Rank: 6Rank: 6
来　自：幻想乡
等　级：侠之大者
威　望：1
帖　子：240
专家分：484
注　册：2010-7-28
第 3 楼
收藏
 得分:0 
你还在纠结啊骚年= =#

If you're not failing every now and again, it's a sign you're not doing anything very innovative.
2012-11-05 18:25
i74126
Rank: 1
等　级：新手上路
帖　子：5
专家分：0
注　册：2015-11-11
第 4 楼
收藏
 得分:0 
谢谢分享1
2016-10-17 15:47
快速回复：用VB6实现俄罗斯方块游戏(游戏编程入门教程)&追爱
数据加载中...
 
　　　



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有，并保留所有权利。
Powered by Discuz, Processed in 0.062839 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved