关闭

用VB6写的一个简单俄罗斯方块代码

标签: vbintegerfunctionalignment游戏网格
8914人阅读 评论(4) 收藏 举报
分类:

网络上有很多俄罗斯方块代码。它们大都为了视觉效果,程序比较复杂,不利于学习游戏编程。所以我写了个简单俄罗斯方块代码,尽量用VB本身的功能,没有复杂的DirectX。

下载(注意修改下载后的扩展名)

界面

mBlock.bas
Attribute VB_Name = "mBlock"
Option Explicit

Private m_Inited As Boolean '是否初始化过

'== 单个方块的信息
Public Const BlockSize As Long = 4
Public Type BlockInfo
    Box(0 To BlockSize - 1, 0 To BlockSize - 1) As Byte
    '        X            ,      Y
End Type

'== 所有方块的数据
Public Const RotateStatusCount As Long = 4

Public Const BlockCount As Long = 5
Public Blocks(0 To RotateStatusCount - 1, 0 To BlockCount - 1) As BlockInfo

'设置方块数据
Private Sub SetBlock(ByRef Item As BlockInfo, ByRef Value As String)
    Dim I As Long
    Dim J As Long
    Dim Idx As Long '字符串位置
    
    Idx = 1
    With Item
        For I = 0 To BlockSize - 1
            For J = 0 To BlockSize - 1
                .Box(J, I) = Val(Mid$(Value, Idx, 1))
                
                Idx = Idx + 1 '指向下一个字符
                
            Next J
        Next I
    End With
    
End Sub

Public Sub InitBlock()
    If m_Inited Then Exit Sub
    m_Inited = True
    
    SetBlock Blocks(0, 0), "0100" & _
                           "0100" & _
                           "0100" & _
                           "0100"
    SetBlock Blocks(1, 0), "0000" & _
                           "1111" & _
                           "0000" & _
                           "0000"
    SetBlock Blocks(2, 0), "0100" & _
                           "0100" & _
                           "0100" & _
                           "0100"
    SetBlock Blocks(3, 0), "0000" & _
                           "1111" & _
                           "0000" & _
                           "0000"
    
    SetBlock Blocks(0, 1), "0100" & _
                           "1110" & _
                           "0000" & _
                           "0000"
    SetBlock Blocks(1, 1), "0100" & _
                           "0110" & _
                           "0100" & _
                           "0000"
    SetBlock Blocks(2, 1), "0000" & _
                           "1110" & _
                           "0100" & _
                           "0000"
    SetBlock Blocks(3, 1), "0100" & _
                           "1100" & _
                           "0100" & _
                           "0000"
    
    SetBlock Blocks(0, 2), "0000" & _
                           "1110" & _
                           "0010" & _
                           "0000"
    SetBlock Blocks(1, 2), "0100" & _
                           "0100" & _
                           "1100" & _
                           "0000"
    SetBlock Blocks(2, 2), "1000" & _
                           "1110" & _
                           "0000" & _
                           "0000"
    SetBlock Blocks(3, 2), "0110" & _
                           "0100" & _
                           "0100" & _
                           "0000"
    
    SetBlock Blocks(0, 3), "0010" & _
                           "1110" & _
                           "0000" & _
                           "0000"
    SetBlock Blocks(1, 3), "0100" & _
                           "0100" & _
                           "0110" & _
                           "0000"
    SetBlock Blocks(2, 3), "0000" & _
                           "1110" & _
                           "1000" & _
                           "0000"
    SetBlock Blocks(3, 3), "1100" & _
                           "0100" & _
                           "0100" & _
                           "0000"
    
    SetBlock Blocks(0, 4), "0000" & _
                           "0110" & _
                           "0110" & _
                           "0000"
    SetBlock Blocks(1, 4), "0000" & _
                           "0110" & _
                           "0110" & _
                           "0000"
    SetBlock Blocks(2, 4), "0000" & _
                           "0110" & _
                           "0110" & _
                           "0000"
    SetBlock Blocks(3, 4), "0000" & _
                           "0110" & _
                           "0110" & _
                           "0000"
    
End Sub

FrmMain.frm
VERSION 5.00
Begin VB.Form FrmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "俄罗斯方块"
   ClientHeight    =   6255
   ClientLeft      =   150
   ClientTop       =   840
   ClientWidth     =   5190
   HasDC           =   0   'False
   Icon            =   "FrmMain.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   6255
   ScaleWidth      =   5190
   StartUpPosition =   3  '窗口缺省
   Begin VB.Timer TmrGame 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   2010
      Top             =   2880
   End
   Begin VB.CommandButton CmdRun 
      Caption         =   "开始"
      Default         =   -1  'True
      Height          =   540
      Left            =   3630
      TabIndex        =   9
      Top             =   5250
      Width           =   1200
   End
   Begin VB.Frame FraValue 
      Caption         =   "得分"
      Height          =   795
      Left            =   3330
      TabIndex        =   7
      Top             =   4020
      Width           =   1800
      Begin VB.TextBox TxtValue 
         Alignment       =   1  'Right Justify
         BackColor       =   &H8000000F&
         BeginProperty Font 
            Name            =   "Fixedsys"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   150
         Locked          =   -1  'True
         TabIndex        =   8
         Text            =   "0"
         Top             =   300
         Width           =   1500
      End
   End
   Begin VB.Frame FraSpeed 
      Caption         =   "当前速度"
      Height          =   795
      Left            =   3330
      TabIndex        =   5
      Top             =   3060
      Width           =   1800
      Begin VB.TextBox TxtSpeed 
         Alignment       =   1  'Right Justify
         BackColor       =   &H8000000F&
         BeginProperty Font 
            Name            =   "Fixedsys"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   150
         Locked          =   -1  'True
         TabIndex        =   6
         Text            =   "0"
         Top             =   300
         Width           =   1500
      End
   End
   Begin VB.Frame FraMax 
      Caption         =   "最高分"
      Height          =   795
      Left            =   3300
      TabIndex        =   3
      Top             =   2100
      Width           =   1800
      Begin VB.TextBox TxtMax 
         Alignment       =   1  'Right Justify
         BackColor       =   &H8000000F&
         BeginProperty Font 
            Name            =   "Fixedsys"
            Size            =   12
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   150
         Locked          =   -1  'True
         TabIndex        =   4
         Text            =   "0"
         Top             =   300
         Width           =   1500
      End
   End
   Begin VB.Frame FraNext 
      Caption         =   "下一个"
      Height          =   1800
      Left            =   3300
      TabIndex        =   1
      Top             =   150
      Width           =   1800
      Begin VB.PictureBox PicNext 
         AutoRedraw      =   -1  'True
         BackColor       =   &H00FFFFFF&
         Height          =   1260
         Left            =   240
         ScaleHeight     =   1200
         ScaleWidth      =   1200
         TabIndex        =   2
         Top             =   300
         Width           =   1260
      End
   End
   Begin VB.PictureBox PicGame 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      Height          =   6060
      Left            =   120
      ScaleHeight     =   6000
      ScaleWidth      =   3000
      TabIndex        =   0
      Top             =   120
      Width           =   3060
   End
   Begin VB.Menu mnuGame 
      Caption         =   "游戏(&G)"
      Begin VB.Menu mnuOption 
         Caption         =   "选项(&O)..."
      End
      Begin VB.Menu mnuAbout 
         Caption         =   "关于(&A)..."
      End
      Begin VB.Menu mnuSep0_0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出(&X)"
      End
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

'== 图格信息
Private Const m_Line As Long = 20   '行数
Private Const m_Col As Long = 10    '列数

'游戏网格
Private m_Grid(0 To m_Col - 1, 0 To m_Line - 1) As Byte

Private m_BoxWidth As Long  '格子的宽度
Private m_BoxHeight As Long '格子的高度

'== 游戏状态

Private m_Playing As Boolean '是否正在运行游戏

Private m_Speed As Long '游戏速度
Private m_Value As Long '当前分数

Private m_Max As Long '最高分数

Private m_ClipTop As Boolean '用于pvHitTest,表示是否超过上边缘

'当前方块的信息
Private m_CurIndex As Long              '方块类型
Private m_CurStatus As Long             '方块旋转状态
Private m_CurColor As Long              '颜色(QBColor索引)
Private m_CurX As Long, m_CurY As Long    '当前位置。单位:图格

'下一个方块的信息
Private m_NextIndex As Long     '方块类型
Private m_NextStatus As Long    '方块旋转状态
Private m_NextColor As Long     '颜色(QBColor索引)

'== 设置信息
Public FastDown As Boolean  '快速下降。False:按一次“下”只下降一行;True:按一次“下”直接落到底
Public RotMode As Boolean   '旋转模式。为假表示顺时针,为真表示逆时针
Public ShowNext As Boolean  '是否显示下一个方块

'键盘定义(按键的KeyDown编码)
Public KeyLeft As Integer   '左移
Public KeyRight As Integer  '右移
Public KeyRot As Integer    '旋转
Public KeyDown As Integer   '落下

'计算得分
Private Function pvValueFormLine(ByVal nLine As Long) As Long
    Debug.Assert nLine >= 0 And nLine <= m_Line
    
    '-- 得分计算方法
    '计算过程:
    ' 100 + 200
    ' 300 + 400
    ' 700 + 800
    '1500 +1600
    '......
    '正好是(2^n-1)*100的形式
    pvValueFormLine = (2 ^ nLine - 1) * 100
    
End Function

'绘制单个格子
'oOut:目的图片框
'nIndex:颜色编号。0表示没有,色彩为QBColor(nIndex)
Private Sub pvDrawBox(ByRef oOut As PictureBox, _
        ByVal nIndex As Long, _
        ByVal X As Single, ByVal Y As Long, _
        ByVal Width As Single, ByVal Height As Single)
    Dim PixelX As Single, PixelY As Single  '1像素所占空间
    
    '利用断言检查参数
    Debug.Assert Not (oOut Is Nothing)          '对象不能为空
    Debug.Assert oOut.ScaleMode <> vbUser       '不能是自定义坐标系
    Debug.Assert nIndex >= 0 And nIndex <= 15   '索引必须在规定的范围内
    Debug.Assert Width > 0 And Height > 0       '大小判断
    
    With oOut
        '计算1像素所占空间
        PixelX = .ScaleX(1, vbPixels, .ScaleMode)
        PixelY = .ScaleY(1, vbPixels, .ScaleMode)
        
        If nIndex = 0 Then
            '绘制白色背景
            oOut.Line (X, Y)-Step(Width, Height), vbWhite, BF
            '绘制边线
            oOut.Line (X + PixelX, Y + PixelY)-Step(Width - PixelX * 2, Height - PixelY * 2), QBColor(nIndex), B
        Else
            '绘制白色边线
            oOut.Line (X, Y)-Step(Width, Height), vbWhite, B
            '绘制填充区域
            oOut.Line (X + PixelX, Y + PixelY)-Step(Width - PixelX * 2, Height - PixelY * 2), QBColor(nIndex), BF
            '绘制白色内边线
            oOut.Line (X + PixelX * 2, Y + PixelY * 2)-Step(Width - PixelX * 4, Height - PixelY * 4), vbWhite, B
        End If
        
    End With
    
End Sub

'绘制游戏画面
Private Sub pvPaint(ByVal hDC As Long)
    Dim I As Long
    Dim J As Long
    Dim X As Single
    Dim Y As Single
    
    Y = 0
    For I = 0 To m_Line - 1
        X = 0
        For J = 0 To m_Col - 1
            '绘制格子
            Call pvDrawBox(PicGame, m_Grid(J, I), X, Y, m_BoxWidth, m_BoxHeight)
            '下一个格子
            X = X + m_BoxWidth
            
        Next J
        
        '下一行格子
        Y = Y + m_BoxHeight
        
    Next I
    
End Sub

'刷新游戏画面
Private Sub pvRefresh()
    With PicGame
        If .AutoRedraw Or .HasDC Then
            Call pvPaint(.hDC)
        End If
        If .AutoRedraw Or .HasDC = False Then
            Call .Refresh
        End If
    End With
End Sub

'更新PicNext的图像
Private Sub pvRefreshNext()
    Dim I As Long, J As Long
    Dim X As Single, Y As Single
    Dim Idx As Long
    
    Debug.Assert m_NextIndex >= -1 And m_NextIndex < BlockCount
    Debug.Assert m_NextStatus >= 0 And m_NextStatus < RotateStatusCount
    Debug.Assert m_NextColor >= 0 And m_NextColor <= 15
    Debug.Assert PicNext.AutoRedraw '自动重画必须为真
    
    If ShowNext And m_NextIndex >= 0 Then '有下一个项目
        With Blocks(m_NextStatus, m_NextIndex)
            Y = 0
            For I = 0 To BlockSize - 1
                X = 0
                For J = 0 To BlockSize - 1
                    '计算颜色
                    If .Box(J, I) Then
                        Idx = m_NextColor
                    Else
                        Idx = 0
                    End If
                    
                    '绘制格子
                    Call pvDrawBox(PicNext, Idx, X, Y, m_BoxWidth, m_BoxHeight)
                    
                    '下一个格子
                    X = X + m_BoxWidth
                    
                Next J
                
                '下一行格子
                Y = Y + m_BoxHeight
                
            Next I
        End With
        
    Else '没有下一个项目
        Idx = 0
        
        Y = 0
        For I = 0 To BlockSize - 1
            X = 0
            For J = 0 To BlockSize - 1
                '绘制格子
                Call pvDrawBox(PicNext, Idx, X, Y, m_BoxWidth, m_BoxHeight)
                
                '下一个格子
                X = X + m_BoxWidth
                
            Next J
            
            '下一行格子
            Y = Y + m_BoxHeight
            
        Next I
        
    End If
    
End Sub

'更新状态显示
Private Sub pvUpdataStatus()
    TxtValue.Text = CStr(m_Value)
    TxtMax.Text = CStr(m_Max)
    
    If m_Playing Then
        If TmrGame.Enabled Then
            CmdRun.Caption = "暂停"
        Else
            CmdRun.Caption = "继续"
        End If
    Else
        CmdRun.Caption = "开始"
    End If
    
End Sub

'生成下一个方块(只是设置数据)
Private Sub pvCreateNextBlock()
    m_NextIndex = Int(Rnd() * BlockCount)
    m_NextStatus = Int(Rnd() * RotateStatusCount)
    m_NextColor = Int(Rnd() * 7) + 1 '在1~7的范围内
End Sub

'更新当前方块
Private Sub pvUpdataCurBlock()
    '类型信息
    m_CurIndex = m_NextIndex
    m_CurStatus = m_NextStatus
    m_CurColor = m_NextColor
    m_CurX = (m_Col - BlockSize) / 2 '居中
    m_CurY = 1 - BlockSize
    
    '生成下一个方块
    Call pvCreateNextBlock
    Call pvRefreshNext
    
End Sub

'将方块加入网格
Private Sub pvFillBlock(ByVal nColor As Long)
    Dim I As Long, J As Long
    Dim X As Long, Y As Long
    
    Debug.Assert m_CurIndex >= 0 And m_CurIndex < BlockCount
    Debug.Assert m_CurStatus >= 0 And m_CurStatus < RotateStatusCount
    Debug.Assert nColor >= 0 And nColor <= 15   '索引必须在规定的范围内
    
    With Blocks(m_CurStatus, m_CurIndex)
        Y = m_CurY
        For I = 0 To BlockSize - 1 'Y循环
            If Y >= 0 And Y < m_Line Then 'Y在范围内
                X = m_CurX
                For J = 0 To BlockSize - 1 'X循环
                    If X >= 0 And X < m_Col Then 'X在范围内
                        If .Box(J, I) Then
                            '设置
                            m_Grid(X, Y) = nColor
                        End If
                    End If
                    
                    X = X + 1
                    
                Next J
            End If
            
            Y = Y + 1
            
        Next I
        
    End With
    
End Sub

'测试是否能放置
Public Function pvHitTest(ByVal X0 As Long, ByVal Y0 As Long, ByVal Status As Long) As Boolean
    Dim I As Long, J As Long
    Dim X As Long, Y As Long
    
    Debug.Assert m_CurIndex >= 0 And m_CurIndex < BlockCount
    Debug.Assert Status >= 0 And Status < RotateStatusCount
    
    m_ClipTop = False
    With Blocks(Status, m_CurIndex)
        Y = Y0
        For I = 0 To BlockSize - 1 'Y循环
                X = X0
                For J = 0 To BlockSize - 1 'X循环
                    If .Box(J, I) Then
                        '判断范围
                        If Y < m_Line And X >= 0 And X < m_Col Then '下、左、右边界判断
                            If Y < 0 Then '超过上边缘
                                m_ClipTop = True
                            Else
                                If m_Grid(X, Y) Then '已占据
                                    pvHitTest = False
                                    Exit Function
                                End If
                            End If
                        Else '在范围外
                            pvHitTest = False
                            Exit Function
                        End If
                        
                    End If
                    
                    X = X + 1
                    
                Next J
                
            Y = Y + 1
            
        Next I
        
    End With
    
    pvHitTest = True
    
End Function

'开始游戏
Private Sub pvStartGame()
    Dim I As Long, J As Long
    
    Debug.Assert m_Playing = False
    
    '清空网格
    For I = 0 To m_Line - 1
        For J = 0 To m_Col - 1
            m_Grid(J, I) = 0
        Next J
    Next I
    
    '计算当前方块
    Call pvCreateNextBlock
    Call pvUpdataCurBlock
    Call pvFillBlock(m_CurColor) '将方块加入网格
    
    '开始游戏
    m_Playing = True
    Speed = 1
    m_Value = 0
    TmrGame.Enabled = m_Playing
    Call pvUpdataStatus
    
    '更新游戏画面
    Call pvRefresh
    
End Sub

'结束游戏
Private Sub pvEndGame()
    '结束游戏
    m_Playing = False
    Speed = 1
    m_Value = 0
    TmrGame.Enabled = m_Playing
    Call pvUpdataStatus
    
    '更新“下一个”
    m_NextIndex = -1
    Call pvRefreshNext
    
End Sub

'尝试消行
Private Sub pvFindLine()
    Dim I As Long, J As Long
    Dim bDel(0 To m_Line - 1) As Boolean
    Dim Count As Long
    Dim Idx As Long
    
    '得到消行的个数
    Count = 0
    For I = 0 To m_Line - 1 '逐行
        '判断满行
        bDel(I) = True
        For J = 0 To m_Col - 1 'X
            If m_Grid(J, I) = 0 Then '存在空格
                bDel(I) = False
                Exit For
            End If
        Next J
        
        If bDel(I) Then
            Count = Count + 1
        End If
        
    Next I
    
    If Count > 0 Then
        '消行
        For I = 0 To m_Line - 1 'y
            If bDel(I) Then
                For J = 0 To m_Col - 1 'X
                    m_Grid(J, I) = 0
                Next J
            End If
        Next I
        
        '更新分数
        m_Value = m_Value + pvValueFormLine(Count)
        If m_Value > m_Max Then m_Max = m_Value
        Me.Speed = m_Value / 2000 + 1 '得分每增加2000分,程序自动将速度调高一档
        Call pvUpdataStatus
        
        '更新游戏画面
        Call pvRefresh
        
        '下移
        Idx = m_Line - 1
        I = Idx
        Do While I >= 0 '逐行
            If bDel(I) Then
            Else
                '复制一行
                If I <> Idx Then
                    For J = 0 To m_Col - 1 'X
                        m_Grid(J, Idx) = m_Grid(J, I)
                    Next J
                End If
                
                '指向下一行
                Idx = Idx - 1
                
            End If
            
            I = I - 1
            
        Loop
        
        '清除多余的行
        For I = 0 To Idx 'Y
            For J = 0 To m_Col - 1 'X
                m_Grid(J, I) = 0
            Next J
        Next I
        
    End If
    
End Sub

'下移一格
'返回值:是否成功
Private Function pvDoMoveDown() As Boolean
    '清除原方块
    Call pvFillBlock(0)
    
    '是否能够下移
    If pvHitTest(m_CurX, m_CurY + 1, m_CurStatus) Then '能够下移
        '更新位置
        m_CurY = m_CurY + 1             '修改坐标
        Call pvFillBlock(m_CurColor)    '将方块加入网格
        
        '更新游戏画面
        Call pvRefresh
        
        pvDoMoveDown = True
        
    Else '不能够下移
        '将方块加入网格
        Call pvFillBlock(m_CurColor)
        
        '判断是否堆满
        If m_ClipTop Then
            Call pvEndGame
            
            'Call VBA.Beep '报警
            MsgBox "GameOver!", vbExclamation Or vbOKOnly
            
        Else
            '消去方块
            Call pvFindLine
            
            '创建新方块
            Call pvUpdataCurBlock
            Call pvFillBlock(m_CurColor) '将方块加入网格
            
            '更新游戏画面
            Call pvRefresh
            
        End If
        
        pvDoMoveDown = False
        
    End If
    
End Function

'水平移动
'返回值:是否成功
Private Function pvDoMoveH(ByVal StepX As Long) As Boolean
    Dim Rc As Boolean
    
    '清除原方块
    Call pvFillBlock(0)
    
    '是否能够移动
    Rc = pvHitTest(m_CurX + StepX, m_CurY, m_CurStatus)
    If Rc Then '能够移动
        '更新位置
        m_CurX = m_CurX + StepX         '修改坐标
        Call pvFillBlock(m_CurColor)    '将方块加入网格
        
        '更新游戏画面
        Call pvRefresh
        
        pvDoMoveH = True
        
    Else '不能够移动
        '将方块加入网格
        Call pvFillBlock(m_CurColor)
        
        Call VBA.Beep
        
        pvDoMoveH = False
        
    End If
    
End Function

'旋转
'返回值:是否成功
Private Function pvDoRotate() As Boolean
    Dim Rc As Boolean
    Dim nTemp As Long
    
    '计算新的状态
    If RotMode = False Then
        nTemp = m_CurStatus + 1
    Else
        nTemp = m_CurStatus - 1
    End If
    nTemp = nTemp And 3
    
    '清除原方块
    Call pvFillBlock(0)
    
    '是否能够旋转
    Rc = pvHitTest(m_CurX, m_CurY, nTemp)
    If Rc Then '能够旋转
        '更新状态
        m_CurStatus = nTemp             '修改状态
        Call pvFillBlock(m_CurColor)    '将方块加入网格
        
        '更新游戏画面
        Call pvRefresh
        
        pvDoRotate = True
        
    Else '不能够旋转
        '将方块加入网格
        Call pvFillBlock(m_CurColor)
        
        Call VBA.Beep
        
        pvDoRotate = False
        
    End If
    
End Function

Private Sub CmdRun_Click()
    If m_Playing Then
        '切换暂停状态
        TmrGame.Enabled = Not TmrGame.Enabled
        
        '更新状态显示
        Call pvUpdataStatus
        
    Else
        Call pvStartGame
    End If
    
End Sub

Private Sub Form_Initialize()
    '初始化随机数
    Call Randomize(Timer)
    
    '初始化方块数据
    Call InitBlock
    
    '设置信息
    FastDown = True
    RotMode = False
    ShowNext = True
    
    '初始化按键
    KeyLeft = vbKeyLeft
    KeyRight = vbKeyRight
    KeyRot = vbKeyUp
    KeyDown = vbKeyDown
    
    
    '初始化comctl32.dll,使应用程序支持WinXP界面风格
    Call InitCommonControls
    
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If m_Playing Then
        If TmrGame.Enabled Then
            Select Case KeyCode
            Case KeyLeft
                Call pvDoMoveH(-1)
                
            Case KeyRight
                Call pvDoMoveH(1)
                
            Case KeyRot
                Call pvDoRotate
                
            Case KeyDown
                If FastDown Then
                    '直到不能落下为止
                    Do While pvDoMoveDown()
                    Loop
                Else
                    Call pvDoMoveDown
                End If
                
            End Select
        End If
    End If
    
End Sub

Private Sub Form_Load()
    '得到格子大小
    With PicGame
        m_BoxWidth = .ScaleWidth / m_Col
        m_BoxHeight = .ScaleHeight / m_Line
    End With
    
    m_Playing = False
    Speed = 1
    m_NextIndex = -1 '没有下一个方块
    
    '更新PicGame
    Call pvRefresh
    
    '更新PicNext
    Call pvRefreshNext
    
    '更新状态显示
    Call pvUpdataStatus
    
End Sub

Private Sub mnuAbout_Click()
    Dim TempStr As String
    TempStr = TempStr & "产品:" & App.ProductName & vbCrLf
    TempStr = TempStr & "版本:" & App.Major & "." & App.Minor & "." & App.Revision & vbCrLf
    TempStr = TempStr & "作者:" & App.CompanyName & vbCrLf
    TempStr = TempStr & "版权:" & App.LegalCopyright & vbCrLf
    TempStr = TempStr & "说明:" & App.FileDescription & vbCrLf
    MsgBox TempStr, vbInformation, "关于" & App.Title
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

Private Sub mnuOption_Click()
    Call FrmOption.DoModal(Me)
    Call pvRefreshNext
End Sub

Private Sub PicGame_Paint()
    Call pvPaint(PicGame.hDC)
End Sub

Private Sub TmrGame_Timer()
    '若没有进行游戏
    If m_Playing = False Then
        TmrGame.Enabled = False
        Exit Sub
    End If
    
    '下移一格
    Call pvDoMoveDown
    
End Sub

'取得/设置 速度
Public Property Get Speed() As Long
    Speed = m_Speed
End Property

Public Property Let Speed(ByVal RHS As Long)
    Dim nItv As Long 'Timer控件的时间间隔
    
    Debug.Assert RHS > 0
    
    m_Speed = RHS
    
    '计算间隔
    nItv = 500 / m_Speed
    If nItv < 1 Then nItv = 1
    TmrGame.Interval = nItv
    
    '更新速度文本框
    TxtSpeed.Text = m_Speed
    
End Property

FrmOption.frm
VERSION 5.00
Begin VB.Form FrmOption 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "选项"
   ClientHeight    =   3225
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4410
   HasDC           =   0   'False
   Icon            =   "FrmOption.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3225
   ScaleWidth      =   4410
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.CheckBox ChkShowNext 
      Caption         =   "显示下一个方块(&N)"
      Height          =   300
      Left            =   2190
      TabIndex        =   4
      Top             =   780
      Width           =   2100
   End
   Begin VB.CheckBox ChkFastDown 
      Caption         =   "立即落下(&F)"
      Height          =   300
      Left            =   2190
      TabIndex        =   3
      Top             =   240
      Width           =   1500
   End
   Begin VB.Frame FraRotate 
      Caption         =   "旋转方向(&R)"
      Height          =   1005
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   1755
      Begin VB.PictureBox PicRotate 
         BorderStyle     =   0  'None
         HasDC           =   0   'False
         Height          =   735
         Left            =   120
         ScaleHeight     =   735
         ScaleWidth      =   1455
         TabIndex        =   14
         Top             =   240
         Width           =   1455
         Begin VB.OptionButton OptRotate 
            Caption         =   "顺时钟"
            Height          =   300
            Index           =   0
            Left            =   120
            TabIndex        =   16
            Top             =   0
            Value           =   -1  'True
            Width           =   1200
         End
         Begin VB.OptionButton OptRotate 
            Caption         =   "逆时钟"
            Height          =   300
            Index           =   1
            Left            =   120
            TabIndex        =   15
            Top             =   360
            Width           =   1200
         End
      End
   End
   Begin VB.Frame FraKey 
      Caption         =   "按键(&K)"
      Height          =   1800
      Left            =   150
      TabIndex        =   5
      Top             =   1290
      Width           =   2400
      Begin VB.TextBox TxtKeyDown 
         Height          =   300
         Left            =   900
         Locked          =   -1  'True
         TabIndex        =   13
         Text            =   "TxtKeyDown"
         Top             =   1350
         Width           =   1275
      End
      Begin VB.TextBox TxtKeyRot 
         Height          =   300
         Left            =   900
         Locked          =   -1  'True
         TabIndex        =   11
         Text            =   "TxtKeyRot"
         Top             =   990
         Width           =   1275
      End
      Begin VB.TextBox TxtKeyRight 
         Height          =   300
         Left            =   900
         Locked          =   -1  'True
         TabIndex        =   9
         Text            =   "TxtKeyRight"
         Top             =   630
         Width           =   1275
      End
      Begin VB.TextBox TxtKeyLeft 
         Height          =   300
         Left            =   900
         Locked          =   -1  'True
         TabIndex        =   7
         Text            =   "TxtKeyLeft"
         Top             =   270
         Width           =   1275
      End
      Begin VB.Label LblKeyDown 
         AutoSize        =   -1  'True
         Caption         =   "落下"
         Height          =   180
         Left            =   210
         TabIndex        =   12
         Top             =   1410
         Width           =   360
      End
      Begin VB.Label LblKeyRot 
         AutoSize        =   -1  'True
         Caption         =   "旋转"
         Height          =   180
         Left            =   210
         TabIndex        =   10
         Top             =   1050
         Width           =   360
      End
      Begin VB.Label LblKeyRight 
         AutoSize        =   -1  'True
         Caption         =   "右移"
         Height          =   180
         Left            =   210
         TabIndex        =   8
         Top             =   690
         Width           =   360
      End
      Begin VB.Label LblKeyLeft 
         AutoSize        =   -1  'True
         Caption         =   "左移"
         Height          =   180
         Left            =   210
         TabIndex        =   6
         Top             =   330
         Width           =   360
      End
   End
   Begin VB.CommandButton CmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消"
      Height          =   360
      Left            =   2880
      TabIndex        =   1
      Top             =   2730
      Width           =   1200
   End
   Begin VB.CommandButton CmdOK 
      Caption         =   "确定"
      Default         =   -1  'True
      Height          =   360
      Left            =   2880
      TabIndex        =   0
      Top             =   2280
      Width           =   1200
   End
End
Attribute VB_Name = "FrmOption"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Function GetKeyNameTextA Lib "user32" (ByVal lParam As Long, ByRef lpBuffer As Any, ByVal nSize As Long) As Long

Private m_Owner As FrmMain '父窗体

Private m_IsOK As Boolean

'将虚拟键码转为字符串
Private Function pvGetKeyName(ByVal KeyCode As Integer) As String
    Dim vCode As Long
    Dim nScan As Long
    Dim lParam As Long
    Dim Buf() As Byte
    Dim Rc As Long
    
    '计算GetKeyNameText所需要的lParam
    vCode = CLng(KeyCode) And &HFFFF&   '计算虚拟键码
    nScan = MapVirtualKey(vCode, 0)     '虚拟键码 To 扫描码
    lParam = (nScan And &HFF) * &H10000 '扫描码 To lParam
    
    '分配字符串缓冲区
    Rc = &H100
    ReDim Buf(0 To Rc - 1)
    
    Rc = GetKeyNameTextA(vCode, Buf(0), Rc)
    If Rc > 0 Then '转换成功
        pvGetKeyName = CStr(KeyCode) & "(" & StrConv(LeftB(Buf, Rc), vbUnicode) & ")"
    Else '转换失败
        pvGetKeyName = CStr(KeyCode)
    End If
    
End Function

Private Sub CmdCancel_Click()
    Unload Me
End Sub

Private Sub CmdOK_Click()
    With m_Owner
        .RotMode = OptRotate(1).Value
        .FastDown = ChkFastDown.Value
        .ShowNext = ChkShowNext.Value
        .KeyLeft = Val(TxtKeyLeft.Text)
        .KeyRight = Val(TxtKeyRight.Text)
        .KeyRot = Val(TxtKeyRot.Text)
        .KeyDown = Val(TxtKeyDown.Text)
    End With
    
    m_IsOK = True
    Unload Me
    
End Sub

Private Sub Form_Load()
    Debug.Assert Not (m_Owner Is Nothing)
    
    With m_Owner
        OptRotate(.RotMode And 1).Value = True
        ChkFastDown.Value = .FastDown And 1
        ChkShowNext.Value = .ShowNext And 1
        TxtKeyLeft.Text = pvGetKeyName(.KeyLeft)
        TxtKeyRight.Text = pvGetKeyName(.KeyRight)
        TxtKeyRot.Text = pvGetKeyName(.KeyRot)
        TxtKeyDown.Text = pvGetKeyName(.KeyDown)
    End With
    
End Sub

Private Sub TxtKeyDown_KeyDown(KeyCode As Integer, Shift As Integer)
    TxtKeyDown.Text = pvGetKeyName(KeyCode)
    KeyCode = 0
End Sub

Private Sub TxtKeyDown_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub

Private Sub TxtKeyLeft_KeyDown(KeyCode As Integer, Shift As Integer)
    TxtKeyLeft.Text = pvGetKeyName(KeyCode)
    KeyCode = 0
End Sub

Private Sub TxtKeyLeft_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub

Private Sub TxtKeyRight_KeyDown(KeyCode As Integer, Shift As Integer)
    TxtKeyRight.Text = pvGetKeyName(KeyCode)
    KeyCode = 0
End Sub

Private Sub TxtKeyRight_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub

Private Sub TxtKeyRot_KeyDown(KeyCode As Integer, Shift As Integer)
    TxtKeyRot.Text = pvGetKeyName(KeyCode)
    KeyCode = 0
End Sub

Private Sub TxtKeyRot_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub

'显示对话框
Public Function DoModal(ByRef Owner As FrmMain) As Boolean
    Debug.Assert Not (Owner Is Nothing)
    
    Set m_Owner = Owner
    m_IsOK = False
    
    '显示对话框
    Me.Show vbModal
    
    DoModal = m_IsOK
    
End Function


0
0

查看评论
* 以上用户言论只代表其个人观点,不代表CSDN网站的观点或立场
    个人资料
    • 访问:301215次
    • 积分:3835
    • 等级:
    • 排名:第8314名
    • 原创:68篇
    • 转载:2篇
    • 译文:1篇
    • 评论:179条