module1.bas

vb做的方块游戏

            End If
        End If
    Next
Next
For i = 1 To 4
    For j = 1 To 4
        If (mWork(i, j) > 0) Then
            mMotherWork(curX + i, curY + j) = mWork(i, j)
        End If
    Next
Next
End Function

Public Sub ClearPic() '清除图形
Dim i As Long, j As Long

For i = 1 To 4
    For j = 1 To 4
        If mWork(i, j) > 0 Then
            mMotherWork(curX + i, curY + j) = 0
        End If
    Next
Next
End Sub

Public Sub ReDrawPic() '重画
Dim i As Long, j As Long

For i = 1 To 4
    For j = 1 To 4
        If mWork(i, j) > 0 Then
            mMotherWork(curX + i, curY + j) = mWork(i, j)
        End If
    Next
Next
End Sub

Public Sub initColor() '初始颜色
Randomize (Timer())
numColor = QBColor(Int(Rnd * (14 - 8 + 1) + 8))
End Sub

Public Sub initPic() '初始化图形
Dim i As Long, j As Long

Randomize (Timer())
PicType = Int(Rnd * mPicNum + 1)

Erase mWork
For i = 1 To 4
    For j = 1 To 4
        mWork(i, j) = mWorkNext(i, j)
    Next
Next

Erase mWorkNext
Select Case PicType
Case m1
    For i = 1 To 4
        mWorkNext(i, 1) = numColor
    Next
Case ml2
    For i = 1 To 2
        mWorkNext(i, 1) = numColor
        mWorkNext(i + 1, 2) = numColor
    Next
Case mr2
    For i = 2 To 3
        mWorkNext(i, 1) = numColor
        mWorkNext(i - 1, 2) = numColor
    Next
Case ml7
    For i = 1 To 3
        mWorkNext(i, 1) = numColor
    Next
    mWorkNext(1, 2) = numColor
Case mr7
    For i = 1 To 3
        mWorkNext(i, 1) = numColor
    Next
    mWorkNext(3, 2) = numColor
Case mm
    For i = 1 To 3
        mWorkNext(i, 2) = numColor
    Next
    mWorkNext(2, 1) = numColor
Case m0
    For i = 1 To 2
        mWorkNext(i, 1) = numColor
        mWorkNext(i, 2) = numColor
    Next
Case mbl7
    For i = 1 To 4
        mWorkNext(i, 1) = numColor
    Next
    mWorkNext(1, 2) = numColor
Case mbr7
    For i = 1 To 4
        mWorkNext(i, 1) = numColor
    Next
    mWorkNext(4, 2) = numColor
Case mbl2
    For i = 1 To 4
        If i < 3 Then mWorkNext(i, 1) = numColor
        mWorkNext(2, 2) = numColor
        If i > 1 And i < 4 Then mWorkNext(i, 3) = numColor
    Next
Case mbr2
    For i = 1 To 4
        If i > 1 And i < 4 Then mWorkNext(i, 1) = numColor
        mWorkNext(2, 2) = numColor
        If i < 3 Then mWorkNext(i, 3) = numColor
    Next
End Select
    
End Sub




Public Sub AlianLT() '转动左上角对齐
Dim i As Long, j As Long, p As Boolean

'转
For j = 1 To 4
    For i = 1 To 4
        mWork(i, j) = mOldWork(4 - j + 1, i)
    Next
Next

'左上角对齐
p = False
While (p = False)
    For i = 1 To 4
        If mWork(i, 1) > 0 Then p = True
    Next
    If p = False Then
        For i = 1 To 4
            For j = 1 To 3
                mWork(i, j) = mWork(i, j + 1)
            Next
        Next
        For i = 1 To 4
            mWork(i, 4) = 0
        Next
    End If
Wend
p = False
While (p = False)
    For i = 1 To 4
        If mWork(1, i) > 0 Then p = True
    Next
    If p = False Then
        For i = 1 To 3
            For j = 1 To 4
                mWork(i, j) = mWork(i + 1, j)
            Next
        Next
        For i = 1 To 4
            mWork(4, i) = 0
        Next
    End If
Wend
End Sub

Public Function MAXxy() As Long '取XY那个最大
If GetXSize > GetYSize Then
    MAXxy = GetXSize
Else
    MAXxy = GetYSize
End If
End Function

Public Function isTurn(L As Long) As Boolean  '是否可转动
Dim i As Long, j As Long, t As Long

isTurn = True
If L = 0 Then t = MAXxy
For i = t To 1 Step -1 'x
    For j = 1 To t 'y
        If mMotherWork(curX + i, curY + j) > 0 Then
            isTurn = False
            Exit Function
        End If
    Next
Next
End Function

Public Function isSet(L As Long) As Boolean  '是否可安放
Dim i As Long, j As Long, Xsize As Long, Ysize As Long

AlianLT '转动左上角对齐
isSet = True
Xsize = GetXSize '这里一定要用XY的实际值才不会出右界
Ysize = GetYSize

For i = 1 To Xsize
    For j = 1 To Ysize
        If mWork(i, j) > 0 And mMotherWork(curX + i - L, curY + j) > 0 Then
                isSet = False
                RemWork '回复原来状态
                Exit Function
        End If
    Next
Next
For i = 1 To Xsize
    For j = 1 To Ysize
        If mWork(i, j) > 0 Then
            mMotherWork(curX + i - L, curY + j) = mWork(i, j) '实际安放数据
        End If
    Next
Next
End Function

Public Sub SaveOldmWork() '保存旧状态
Dim i As Long, j As Long
For i = 1 To 4
    For j = 1 To 4
        mOldWork(i, j) = mWork(i, j)
    Next
Next
End Sub

Public Sub RemWork() '回复之前状态
Dim i As Long, j As Long
For i = 1 To 4
    For j = 1 To 4
        mWork(i, j) = mOldWork(i, j)
    Next
Next
End Sub

Public Function GetXSize() As Long '取X轴长度
Dim i As Long, j As Long
For i = 4 To 1 Step -1
    For j = 1 To 4
        If mWork(i, j) > 0 Then
            GetXSize = i
            Exit Function
        End If
    Next
Next
End Function

Public Function GetYSize() As Long '取Y轴长度
Dim i As Long, j As Long
For i = 4 To 1 Step -1
    For j = 1 To 4
        If mWork(j, i) > 0 Then
            GetYSize = i
            Exit Function
        End If
    Next
Next
End Function

'===============================排行榜==================================
Public Sub GetRecord(lngRecord As Long)   '排行榜
Dim n As Integer, mName(1 To 11) As String, mRecord(1 To 11) As Long, a As String, t As Long
Dim i As Long, j As Long, lngtmp As Long, strtmp As String, strName As String * 12
Dim typeName As String '什么类型的
Dim typeFile As String '类型对应的文件名
Dim mySet As Long '名次

On Error Resume Next

n = FreeFile

If frmMain.Option1.Value = True Then
    typeName = "初级"
    typeFile = "1"
ElseIf frmMain.Option2.Value = True Then
    typeName = "中级"
    typeFile = "2"
ElseIf frmMain.Option3.Value = True Then
    typeName = "高级"
    typeFile = "3"
End If

a = appPath & "tetris" & typeFile & ".ini"
If Dir(a) <> "" Then
    Open a For Input As #n
    Do While Not EOF(n)
        t = t + 1
        Input #n, mName(t), mRecord(t) '读出文件
    Loop
    Close #n
    
    If ((t >= 10) And (lngRecord > mRecord(t))) Or t < 10 Then '测试能否入围
        For i = 1 To t
            If lngRecord > mRecord(i) Then mySet = i: Exit For
        Next
        If mySet = 0 Then mySet = t + 1
        strName = InputBox("请输入你的名字:", typeName & "排行榜")
        If Trim(Mid(strName, 1, Len(strName) - 1)) = "" Then strName = "Bad Guy"
        strName = strName & "                 "
        t = t + 1
        mName(t) = strName
        mRecord(t) = lngRecord
        For i = 1 To t - 1 '排列
            For j = i + 1 To t
                If mRecord(j) > mRecord(i) Then
                    lngtmp = mRecord(i)
                    mRecord(i) = mRecord(j)
                    mRecord(j) = lngtmp
                    strtmp = mName(i)
                    mName(i) = mName(j)
                    mName(j) = strtmp
                End If
            Next
        Next
        
        n = FreeFile
        Open a For Output As #n
        If t > 10 Then t = 10 '只取前十名
        For i = 1 To t '将排好后的数据写入文件
            Write #n, mName(i), mRecord(i)
        Next
        Close #n
        
        strtmp = ""
        For i = 1 To t
            strtmp = strtmp & vbCrLf & "第 " & CStr(i) & " 名: " & mName(i) & "  分数: " & CStr(mRecord(i))
        Next
        strtmp = strtmp & vbCrLf & vbCrLf & "恭喜您排在第 " & CStr(mySet) & " 位"
        MsgBox strtmp & myRight, , typeName & "排行榜"
    Else
        MsgBox "Game Over!" & myRight
    End If
Else
    strName = InputBox("请输入你的名字:", typeName & "排行榜")
    If Trim(Mid(strName, 1, Len(strName) - 1)) = "" Then strName = "Bad Guy"
    strName = strName & "                 "
    Open a For Output As #n
    Write #n, strName, lngRecord
    Close #n
    
    MsgBox "第 一名:" & strName & "  分数:" & CStr(lngRecord) & myRight, , typeName & "排行榜"
End If
End Sub

Public Sub CheckType() '如果是中高级则每升一级底加r行
Dim i As Long, j As Long, r As Long, n As Long
On Error GoTo merr
If frmMain.Option1.Value = True Then Exit Sub
frmMain.Timer1.Enabled = False
r = CLng(frmMain.lblRecord) \ mAddLine

If r = 0 Then Exit Sub
If r > 5 Then r = 5
    For n = 1 To r '每次向上移动一行，移动r次
        'For j = 1 To mRow - r '23
        For j = 1 To mRow - 1
            For i = 1 To mLine '10
                mMotherWork(i, j) = mMotherWork(i, j + 1)
            Next
        Next
    Next

    For j = mRow To (mRow - r + 1) Step -1 '删除无用行
        For i = 1 To mLine
            mMotherWork(i, j) = 0
        Next
    Next

    DoEvents
    isRePaint = True
    frmMain.picMother.Cls
    paintPic True '刷新
    
    Randomize
    For j = mRow To (mRow - r + 1) Step -1 '加一，害我找了好一阵
        For i = 1 To mLine
            r = CLng(Int(Rnd * (17 - 8 + 1) + 8)) '颜色数为8-14,如果为15,16,17则设为0
            Select Case r
                Case 15, 16, 17
                r = 0
            End Select
            If r > 0 Then r = QBColor(CInt(r))
            mMotherWork(i, j) = r
        Next
        DoEvents
        paintPic True '刷新
        Sleep 50
    Next
    DoEvents
    isRePaint = True
    frmMain.picMother.Cls
    paintPic True '刷新

frmMain.Timer1.Enabled = True
Exit Sub
merr:
MsgBox Err.Description
End Sub

Public Function CurL() As Long '当前行数
Dim i As Long, j As Long
For j = 1 To mRow
    For i = 1 To mLine
        If mMotherWork(i, j) > 0 Then
            CurL = mRow - j + 1
            Exit Function
        End If
    Next
Next
End Function

Public Sub SelectType() '选择一种图形
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
Randomize
LineType = CLng(Int(Rnd * 13))
isRePaint = True '全部重画
frmMain.picMother.Cls
paintPic (True)
End Sub

Public Function CheckGameOver() As Boolean '如果第一行有值就说明游戏结束了
Dim i As Long

CheckGameOver = False
For i = 1 To mLine
    If mMotherWork(i, 1) > 0 Then
        CheckGameOver = True
        Exit Function
    End If
Next
End Function