一个VB编写的俄罗斯方块

'VB语言版俄罗斯方块
'Totoo、Aoo34智造（一个人的两个名字），一些方块，很多计算

Const WN As Integer = 10, HN As Integer = 20
Const Boxl As Integer = 372, BoxNum As Integer = 200

 

Private Sub Combo1_DropDown()
Turn
End Sub

Private Sub Timer1_Timer()
Timer1.Interval = TimeLen
CheckTop
Fail
Cleaner
XFull
End Sub

Private Sub Form_Load()
    Call Load
Form1.Width = Screen.Width
Form1.Height = Screen.Height
    'For a = 0 To 3
    With Label1
    .Caption = "                   华康强大                                                                           华夏复兴"
    .Width = Form1.ScaleWidth - 10 * Boxl
    .Height = 20 * Boxl
    .Move 10 * Boxl, 0
    End With
    'Next a
With Label2
.Move 0, 20 * Boxl
.Caption = "经以此纪念伟大的盗版者，中国人民的英雄——雷华康！"
End With
Form1.Caption = "w,a,s,d分别为变形、左、右及降落"
    TimeLen = 200
Timer1.Interval = 1000
Call ClearUpEr
ShapeAdd
    For a = 0 To 3
With Shape2(a)
.Width = Boxl
.Height = Boxl
End With
    Next a
    
End Sub
 
Private Sub ClearUpEr()
'Totoo作品
With Form1
.Width = WN * 372 / 2 * 3
.Height = 27 * Boxl
End With
    Dim Ia As Integer, ib As Integer
    Dim x(BoxNum) As Integer, y(BoxNum) As Integer
    x(1) = 0
    y(1) = 0
        For a = 0 To 199
With Shape1(a)
.Width = Boxl * (Iret + 1)
.Height = Boxl * (Iret + 1)
End With
    Ia = Ia + 1
        If (Ia <> 0) And (a Mod WN = 0) Then Ia = 0: ib = ib + 1
    x(a) = Boxl * Ia
    y(a) = Boxl * (ib - 1)
    Shape1(a).Move x(a), y(a)
        Next a
'Totoo作品
End Sub

Sub ShapeAdd()
'Totoo作品
Dim Sret As Integer
x(1) = 0: y(1) = 0: stet = 3
        For j = 2 To 4
        If j = 4 Then
            If x(3) = 1 And y(3) = 1 Then
                        Rndget Sret, 2
            If Sret = 0 Then GoTo Four:
            End If
        End If
    Rndget Sret, 2
    If Sret = 1 Then
        Sret = j
        NextBox Sret, Sret - 1, 1, 1
    Else
        Sret = j
        NextBox Sret, Sret - 1, 1, 0
    End If

        Next j
        
If 1 = 2 Then
Four:
Rndget Sret, 2
Select Case x(2)
    Case 1:
            If Sret = 1 Then
            NextBox 4, 2, 1, 1
            Else
            NextBox 4, 3, -1, 1
            End If
    Case 0:
            If Sret = 1 Then
            NextBox 4, 2, 1, 0
            Else
            NextBox 4, 3, -1, 0
            End If
End Select
End If
initialize:
        For a = 1 To 4
With Shape2(a - 1)
.Move x(a) * Boxl, y(a) * Boxl
.Width = Boxl
.Height = Boxl
End With
        Next a
corect:
    Dim reta3, reta4 As Integer
        For a = 1 To 4
    reta3 = x(a)
        If reta3 > reta4 Then: reta4 = reta3
        Next a
    Randomize
    reta3 = Fix(Rnd * (9 - reta4)) + 1
        For a = 1 To 4
    x(a) = x(a) + reta3
        Next a
'Totoo作品
End Sub

Sub Cleaner()
'Totoo作品，中国智造
    For a = 1 To 10
        For b = 1 To 20
            If BF(a, b) = 1 Then
Shape1(a + (b - 1) * 10 - 1).FillStyle = 0
            Else
Shape1(a + (b - 1) * 10 - 1).FillStyle = 1
            End If
        Next b
    Next a

End Sub

Sub CheckTop()
    'Totoo作品，中国智造
On Error GoTo done:
        For a = 1 To 4
    If x(a) + 1 < 19 Then On Error Resume Next
    If y(a) > 18 Then GoTo done:
    If BF(x(a) + 1, y(a) + 2) = 1 Then GoTo done:

On Error GoTo Over:
    If x(a) + 1 > 20 Or x(a) + 1 < 1 Then GoTo Over:
        Next a
    If 1 = 2 Then
Over:
    Call ClsBox
        'Timelen = 500
        Call ShapeAdd
        'MsgBox "GameOver!": End
    End If
    If 1 = 2 Then
done:
        For a = 1 To 4
            If BF(x(a) + 1, y(a) + 1) = 1 Then GoTo Over:
        Next a
        For a = 1 To 4
    BF(x(a) + 1, y(a) + 1) = 1
        Next a
    Call ShapeAdd: If BottomAsk = True Then TimeLen = 500: BottomAsk = False
    End If
Pass:
End Sub

Private Sub Turn()
    Dim ret As Integer
        For a = 1 To 4
        ret = x(a) - x(3): mY(a) = ret + y(3)
        ret = y(a) - y(3): mX(a) = ret + x(3)
        
        
        
doit:
        
'        On Error GoTo chc:
'        If 1 = 2 Then
'        If syssin Then
'chc:
'        On Error Resume Next
'        Else
'        On Error GoTo handle:
'        End If
'        End If
'
     Next a
'
'If 1 = 2 Then
'handle:
' If BF(mX(a) + 2, mY(a) + 2) = 1 Then GoTo Pass:
'End If
    ComeTure
'Pass:
     'Totoo作品，中国智造
End Sub

Sub XFull() 'Totoo作品，中国智造
    Dim Ia As Integer, I As Integer
    Dim mY As Integer, BfRet(1 To 10, 1 To 20) As Integer
    Dim Cleanit As Boolean
        For b = 1 To 20
            For a = 1 To 10
                If BF(a, b) = 1 Then Ia = Ia + 1
            Next a
                If Ia = 10 Then I = I + 1: Toper(I) = b:  '记录满格
    Ia = 0
        Next b
    If I <> 0 Then
        For b = 1 To I
            For a = 1 To 10
        BF(a, Toper(b)) = 0
            Next a
socre = socre + 200
            Next b
Label2.Caption = "得分：" & Str(socre)
    End If
    If (Clean = True) Then
        For a = 1 To 10
    Cleanit = False
            For b = 1 To 20
        mY = 0
        mY = BF(a, b)
        If BF(a, b) = 1 Then
                For c = 1 To I
            If Toper(c) <> 0 Then
                If b < Toper(c) Then
                mY = mY + 1
                Cleanit = True
                End If
            End If
            If c = I Then
                If b + mY > 20 Then GoTo Pass:
            BfRet(a, b + mY - 1) = 1
                If 1 = 2 Then
Pass:
                For d = 1 To 10
                BfRet(a, 20) = 1
                Next d
                End If
        End If
    Next c
    End If
    mY = 0
    Next b
    If Cleanit = True Then
    For b = 1 To 20
    BF(a, b) = BfRet(a, b)
    BfRet(a, b) = 0
    Next b
    End If
Next a
End If
    For L = 1 To I
    Toper(L) = 0
    Next L
End Sub

 

Private Sub Save()
    Dim SFN As String
    CommonDialog1.ShowOpen
    SFN = CommonDialog1.FileName
    If SFN <> "" Then
    Open SFN & ".totooDat" For Output As #1
    For a = 1 To 10
    For b = 1 To 20
    Print #1, BF(a, b)
    Next b, a
    Print socre
    Close #1
    End If
End Sub

Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
        Select Case KeyCode
        Case 65, 37: MoveLeft
        Case 68, 39: MoveRight
        Case 87, 38: Turn
        Case 83, 40: TimeLen = 20: BottomAsk = True
        End Select
    If KeyCode = 13 Then
        EntI = EntI + 1
            If EntI Mod 2 = 1 Then
            TimeLen = 10
            Else: TimeLen = 1000: End If
    End If
End Sub

Private Sub Fail()
    Clean = True
        For a = 1 To 4
    y(a) = y(a) + 1
Shape2(a - 1).Move x(a) * Boxl, y(a) * Boxl
        Next a
End Sub

'Totoo作品，中国智造

Public x(1 To 4), y(1 To 4) As Integer
Public BF(1 To 10, 1 To 20) As Integer, mX(1 To 4), mY(1 To 4) As Integer
Public retY(1 To 20), Toper(1 To 20) As Integer, Saver(1 To 10) As String
Public socre, Iret, MarkNum As Integer, TimeLen As Integer, EntI As Integer
Public SystemAsk As Boolean, BottomAsk As Boolean, ret As String
Public Repeat As Boolean, Clean As Boolean

Public Sub MoveLeft()
    'Totoo作品
    On Error GoTo Pass:
    For a = 1 To 4
    mX(a) = x(a) - 1
    If BF(mX(a) + 1, y(a) + 1) = 1 Then GoTo Pass:
    Next a
    For a = 1 To 4
    x(a) = mX(a)
    Next a
Pass:
End Sub

Public Sub MoveRight()
    On Error GoTo Pass:
    For a = 1 To 4
    mX(a) = x(a) + 1
    If BF(mX(a) + 1, y(a) + 1) = 1 Then GoTo Pass:
    Next a
    For a = 1 To 4
    x(a) = mX(a)
    Next a
Pass:
End Sub

Public Sub Load()

End Sub

Public Sub ClsBox()
For a = 1 To 10
    For b = 1 To 20
    BF(a, b) = 0
    Next b
Next a
End Sub

Public Sub NextBox(a As Integer, b As Integer, c As Integer, d As Integer)
If d = 0 Then
x(a) = x(b): y(a) = y(b) + c
Else
x(a) = x(b) + c: y(a) = y(b)
End If
End Sub

Public Sub Rndget(a, b As Integer)
Randomize
a = Fix(Rnd * b)
End Sub

Public Sub ComeTure()
For a = 1 To 4
x(a) = mX(a): y(a) = mY(a)
Next a
End Sub

'用400行完成，希望对学习者有所帮助！

转载于:https://www.cnblogs.com/totoo/p/index.html