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

网络上有很多俄罗斯方块代码。它们大都为了视觉效果，程序比较复杂，不利于学习游戏编程。所以我写了个简单俄罗斯方块代码，尽量用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