m_fk.bas

VB制作的一款小游戏软件

                Next
            Next
            CanMove = True
        End If
    Case 2
        For i = 0 To 3
            For j = 0 To 3
                If Now_fk.Data(i, j) <> 0 Then GoTo lab2
            Next
            If j = 4 Then counter = counter + 1
        Next
        
lab2:
        NewX = Now_fk.StartX - BoxWidth
        NewY = Now_fk.StartY
        
        If NewX / BoxWidth + counter >= 0 Then
            For i = 0 To 3
                For j = 0 To 3
                    col = i + NewX / BoxWidth
                    row = j + NewY / BoxWidth
                    If col >= 0 And row >= 0 And Now_fk.Data(i, j) <> 0 And col < CCol And row < CLine Then
                        If grid(row, col) <> 0 Then CanMove = False: Exit Function
                    End If
                Next
            Next
            CanMove = True
        End If
    Case 3
        i = 3
        Do While i > 0
            For j = 0 To 3
                If Now_fk.Data(i, j) <> 0 Then GoTo lab3
            Next
            i = i - 1
            If j = 4 Then counter = counter + 1
        Loop
        
lab3:
    
        NewX = Now_fk.StartX + BoxWidth
        NewY = Now_fk.StartY

        If NewX / BoxWidth + (4 - counter) <= CCol Then
            For i = 0 To 3
                For j = 0 To 3
                    col = i + NewX / BoxWidth
                    row = j + NewY / BoxWidth
                    If col >= 0 And row >= 0 And Now_fk.Data(i, j) <> 0 And col < CCol And row < CLine Then
                        If grid(row, col) <> 0 Then CanMove = False: Exit Function
                    End If
                Next
            Next
            CanMove = True
        End If
    End Select
End Function

Public Function fk_Left()
    If True = CanMove(2) Then
        fk_Clear
        Now_fk.StartX = Now_fk.StartX - BoxWidth
        InSertGrid
    End If
End Function

Public Function fk_Right() As Boolean
    If True = CanMove(3) Then
        fk_Clear
        Now_fk.StartX = Now_fk.StartX + BoxWidth
        InSertGrid
    End If
End Function

Public Function fk_Down() As Boolean
    If True = CanMove(1) Then
        fk_Clear
        Now_fk.StartY = Now_fk.StartY + BoxWidth
        InSertGrid
    Else
        Call EndOfDown
    End If
End Function

Public Function fk_Change()
    Dim i As Integer, j As Integer
    Dim Temp_fk As m_fk
    Dim col As Integer, row As Integer
    Dim Lcounter As Integer, Rcounter As Integer
    Dim Dcounter As Integer
    
    Call Create_fk(Temp_fk, Now_fk.Kinds, Now_fk.StartX, Now_fk.StartY)
    
       For i = 0 To 3
           For j = 0 To 3
               If Temp_fk.Data(i, j) <> 0 Then GoTo lab1
           Next
           If j = 4 Then Lcounter = Lcounter + 1
       Next
lab1:
       i = 3
       Do While i > 0
           For j = 0 To 3
               If Temp_fk.Data(i, j) <> 0 Then GoTo lab2
           Next
           i = i - 1
           If j = 4 Then Rcounter = Rcounter + 1
       Loop
lab2:
        i = 3
        Do While i > 0
            For j = 0 To 3
                If Temp_fk.Data(j, i) <> 0 Then GoTo lab3
            Next
            i = i - 1
            If j = 4 Then Dcounter = Dcounter + 1
        Loop
        
lab3:
    If Temp_fk.StartX / BoxWidth + Lcounter >= 0 Then
        If Temp_fk.StartX / BoxWidth + (4 - Rcounter) <= CCol Then
            If Temp_fk.StartY / BoxWidth + (4 - Dcounter) <= CLine Then
                
                For i = 0 To 3
                    For j = 0 To 3
                        col = i + Temp_fk.StartX / BoxWidth
                        row = j + Temp_fk.StartY / BoxWidth
                        If col >= 0 And row >= 0 And col < CCol And row < CLine And Temp_fk.Data(i, j) <> 0 Then
                            If grid(row, col) <> 0 Then Exit Function
                        End If
                    Next
                Next
                
                fk_Clear
                With Now_fk
                    .color = Temp_fk.color
                    .StartX = Temp_fk.StartX
                    .StartY = Temp_fk.StartY
                    For i = 0 To 3
                        For j = 0 To 3
                            .Data(i, j) = Temp_fk.Data(i, j)
                        Next
                    Next
                    .ChangeType = Temp_fk.ChangeType
                    .fk_Kind = Temp_fk.fk_Kind
                    .Kinds = Temp_fk.Kinds
                End With
                InSertGrid
                
            End If
        End If
    End If
End Function


Private Function fk_Clear()
    Dim i As Integer, j As Integer
    For i = 0 To 3
        For j = 0 To 3
            If Now_fk.Data(i, j) <> 0 Then Call ClearFill(Now_fk.StartX + i * BoxWidth, Now_fk.StartY + j * BoxWidth, vbWhite)
        Next
    Next
End Function

Private Function ClearFill(ByVal X As Single, ByVal Y As Single, ByVal color As Long)
    frmMain.blackGrid.Line (X + 2, Y + 2)-(X + BoxWidth - 2, Y + BoxWidth - 2), color, BF
End Function

Public Function InSertGrid()
    Dim i As Integer, j As Integer
    For i = 0 To 3
        For j = 0 To 3
            If Now_fk.Data(i, j) <> 0 And Now_fk.StartY + j * BoxWidth >= 0 Then Call FillEveryOne(Now_fk.StartX + i * BoxWidth, Now_fk.StartY + j * BoxWidth, Now_fk.color)
        Next
    Next
End Function

Private Function FillEveryOneNext(ByVal X As Single, ByVal Y As Single, ByVal color As Long)
    frmMain.bgridnext.Line (X + 2, Y + 2)-(X + BoxWidth - 2, Y + BoxWidth - 2), color, BF
End Function

Private Function FillEveryOne(ByVal X As Single, ByVal Y As Single, ByVal color As Long)
    frmMain.blackGrid.Line (X + 2, Y + 2)-(X + BoxWidth - 2, Y + BoxWidth - 2), color, BF
End Function


Private Function EndOfDown()
    Dim i As Byte, j As Byte
    Dim col As Integer, row As Integer


    For i = 0 To 3
        For j = 0 To 3
            If Now_fk.Data(i, j) <> 0 Then
                col = i + Now_fk.StartX / BoxWidth
                row = j + Now_fk.StartY / BoxWidth
                If col >= 0 And row >= 0 Then
                   grid(row, col) = Now_fk.Data(i, j)
                End If
            End If
        Next
    Next

    For i = 0 To 3
        For j = 0 To 3
             Now_fk.Data(i, j) = 0
        Next
    Next

    '尝试消去方块
    Call Delete_fk

    frmMain.TopToBottom.Enabled = False
    If False = gameover Then frmMain.GameTimer.Enabled = True
End Function

Private Function Delete_fk()
    Dim i As Integer, j As Integer, K As Integer
    Dim counter As Integer
    Dim color As Long
    
    counter = 0
    Do While True
        For i = CLine - 1 To 0 Step -1
            For j = 0 To CCol - 1
                If grid(i, j) = 0 Then Exit For
            Next
            
            If j = CCol Then '消去
                counter = counter + 1
                
                For K = 0 To CCol - 1
                     grid(i, K) = 0
                     Call FillEveryOne(K * BoxWidth, i * BoxWidth, vbWhite)
                Next
                
                For K = i - 1 To 0 Step -1
                    For j = 0 To CCol - 1
                        grid(K + 1, j) = grid(K, j)
                    Next
                Next
                
                '顶部置空一行
                For j = 0 To CCol - 1
                    grid(0, j) = 0
                Next
           
                For K = 0 To CLine - 1
                    For j = 0 To CCol - 1
                        If grid(K, j) = 0 Then color = vbWhite Else color = grid(K, j)
                        Call FillEveryOne(j * BoxWidth, K * BoxWidth, color)
                    Next
                Next
                
                Exit For
            End If
        Next
        If i = -1 Then Exit Do
    Loop
    
    If counter > 0 Then
        total = total + counter ^ 2 * 100
        If counter > 1 Then total = total - 100
        frmMain.Text1.Item(0).Text = total
        If total > max Then max = total
        
        
        If total / 5000000 > speed And speed < 9 Then
            speed = speed + 1: frmMain.Text1.Item(2) = speed '速度显示控制
            
            '实际速度控制
             frmMain.TopToBottom.Interval = frmMain.TopToBottom.Interval - 70
        End If
    End If
End Function

Private Function GameIsOver()
    Dim i As Integer, j As Integer
    
    For i = 0 To CLine - 1
        For j = 0 To CCol - 1
            grid(i, j) = 0
            Call FillEveryOne(j * BoxWidth, i * BoxWidth, vbBlue)
        Next
    Next
    Call save
    
    frmMain.TopToBottom.Enabled = False
    frmMain.GameTimer.Enabled = False
    gameover = True
    starting = False
End Function

Function save()
On Error Resume Next
    Dim strTemp As String
    strTemp = App.Path & "\data.bin"
    Open strTemp For Binary As #1
    Put #1, 8, max
    Close #1
End Function