网络上有很多俄罗斯方块代码。它们大都为了视觉效果，程序比较复杂，不利于学习游戏编程。所以我写了个简单俄罗斯方块代码，尽量用VB本身的功能，没有复杂的DirectX。
下载（注意修改下载后的扩展名）
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
|
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
|
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
|