module1.bas

vb做的方块游戏

Attribute VB_Name = "Module1"
Option Explicit
'========================================================================================
'                       本程序由梁博荣制作　2001.6.18
'                       邮箱：[e-mail]
'                       网址：http://longone.126.com
'========================================================================================


Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Type RECT
        x1 As Long
        x2 As Long
        y1 As Long
        y2 As Long
End Type

Public Enum mPicType
    m1 = 1
    ml2 = 2
    mr2 = 3
    ml7 = 4
    mr7 = 5
    mm = 6
    m0 = 7
    
    mbl7 = 8
    mbr7 = 9
    mbl2 = 10
    mbr2 = 11
End Enum

'===========================================================================================

Public mLine As Long   '画板宽
Public mRow As Long   '高
Public Const mW = 20 '单个方格宽
Public Const mH = 20 '高
Public mPicNum As Long  '图形有几种
Public Const mAddLine = 10000 '一万分加行
Public Const mSelectLineType = 7000 '7000分改变图形
Public Const myRight = vbCrLf & vbCrLf & vbCrLf & _
                        "作者：梁博荣" & vbCrLf & _
                        "信箱：[e-mail]" & vbCrLf & _
                        "网址：http://3m26d.at.china.com" & vbCrLf & vbCrLf & _
                        "---  3m26d工作室 2001.6.18  ---"
Const pi = 3.14159265

Public mMotherWork() As Long
Public mOldMotherWork() As Long
Public mWork(1 To 4, 1 To 4) As Long
Public mWorkNext(1 To 4, 1 To 4) As Long
Public mOldWork(1 To 4, 1 To 4) As Long
Public curX As Long, curY As Long
Public numColor As Long '图形颜色
Public numColorNext As Long
Public PicType As mPicType '什么图形
Public lngH As Long, lngL As Long '边线颜色
Public isRePaint As Boolean '是否要全部重画
Public LineType As Long '方格线的形状

Public appPath As String '路径
Public isPuse As Boolean '暂停
Public isInsertPic As Boolean '记录能否插入图形
Public OldIntervalDown As Long '旧的时间间隔
Public isKeyDown As Boolean '是否已按下DOWN
Public isKeyBusy As Boolean '是否已有键按下了
Public isKeySpace As Boolean '是否快速
Public mBase As Long   '定时器的基数
Public mLineHigh As Long '行高
Public isStart As Boolean '游戏开始按键才有效
Public SelectTypeRecord As Long '记录分数改变图形
Public GameIsOver As Boolean '游戏是否已结束


Public Sub paintPic(BL As Boolean)  '根据每格的颜色值重画图形 B=Big L=Littel
Dim i As Long, j As Long
Dim mRect As RECT
Dim L As Long
Dim myPic As PictureBox
Dim hh As Long, ww As Long
Dim x As Single, y As Single, rr As Single

If isRePaint Then
    'Erase mOldMotherWork '要求重画 动态数组不能用erase
    isRePaint = False
    ReDim mOldMotherWork(1 To mLine, 1 To mRow)
End If

If BL Then
  For i = 1 To mLine
    For j = 1 To mRow
        If mMotherWork(i, j) <> mOldMotherWork(i, j) Then
            If mMotherWork(i, j) > 0 Then
                mRect.x1 = (i * mW + 1 - mW)
                mRect.y1 = (j * mH + 1 - mH)
                mRect.x2 = (mRect.x1 + mW - 1)
                mRect.y2 = (mRect.y1 + mH - 1)
                frmMain.picMother.Line (mRect.x1, mRect.y1)-(mRect.x2, mRect.y2), mMotherWork(i, j), BF
                frmMain.picMother.Line (mRect.x2, mRect.y1)-(mRect.x2, mRect.y2), lngL
                frmMain.picMother.Line (mRect.x1, mRect.y2)-(mRect.x2, mRect.y2), lngL
                frmMain.picMother.Line (mRect.x1, mRect.y1)-(mRect.x2, mRect.y1), lngH
                frmMain.picMother.Line (mRect.x1, mRect.y1)-(mRect.x1, mRect.y2), lngH
                
                'LineType = 11
                Select Case LineType
                Case 1
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 3), lngL
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y1 + 3), lngL
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH
                Case 9
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 3), lngL
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y1 + 3), lngL
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH

                    x = mRect.x1 + (mRect.x2 - mRect.x1) \ 2
                    y = mRect.y1 + (mRect.y2 - mRect.y1) \ 2
                    rr = 4
                    frmMain.picMother.CurrentX = x
                    frmMain.picMother.CurrentY = y
                    frmMain.picMother.Circle (x, y), rr, lngH, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngL, 226 * pi / 180, 45 * pi / 180
                Case 10
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 3), lngH
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y1 + 3), lngH
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL

                    x = mRect.x1 + (mRect.x2 - mRect.x1) \ 2
                    y = mRect.y1 + (mRect.y2 - mRect.y1) \ 2
                    rr = 4
                    frmMain.picMother.CurrentX = x
                    frmMain.picMother.CurrentY = y
                    frmMain.picMother.Circle (x, y), rr, lngH, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngL, 226 * pi / 180, 45 * pi / 180
                Case 11
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 3), lngH
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y1 + 3), lngH
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL
                    
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y1 + 5)-(mRect.x1 + 5, mRect.y2 - 5), lngH
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y1 + 5)-(mRect.x2 - 5, mRect.y1 + 5), lngH
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y2 - 5)-(mRect.x2 - 5, mRect.y2 - 5), lngL
                    frmMain.picMother.Line (mRect.x2 - 5, mRect.y1 + 5)-(mRect.x2 - 5, mRect.y2 - 5), lngL
                Case 12
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 3), lngL
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y1 + 3), lngL
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH
                    
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y1 + 5)-(mRect.x1 + 5, mRect.y2 - 5), lngH
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y1 + 5)-(mRect.x2 - 5, mRect.y1 + 5), lngH
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y2 - 5)-(mRect.x2 - 5, mRect.y2 - 5), lngL
                    frmMain.picMother.Line (mRect.x2 - 5, mRect.y1 + 5)-(mRect.x2 - 5, mRect.y2 - 5), lngL
                Case 2
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 3), lngH
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y1 + 3), lngH
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL
                Case 3
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 5), lngH 'L
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 5, mRect.y1 + 3), lngH 'T
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngL 'B
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 5)-(mRect.x2 - 3, mRect.y2 - 3), lngL 'R
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 5)-(mRect.x2 - 5, mRect.y1 + 3), lngL '斜线
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y1 + 5), lngH '
                Case 4
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x1 + 3, mRect.y2 - 5), lngL 'L
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y1 + 3)-(mRect.x2 - 5, mRect.y1 + 3), lngL 'T
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y2 - 3), lngH 'B
                    frmMain.picMother.Line (mRect.x2 - 3, mRect.y1 + 5)-(mRect.x2 - 3, mRect.y2 - 3), lngH 'R
                    frmMain.picMother.Line (mRect.x1 + 3, mRect.y2 - 5)-(mRect.x2 - 5, mRect.y1 + 3), lngH '斜线
                    frmMain.picMother.Line (mRect.x1 + 5, mRect.y2 - 3)-(mRect.x2 - 3, mRect.y1 + 5), lngL '
                Case 5
                    x = mRect.x1 + (mRect.x2 - mRect.x1) \ 2
                    y = mRect.y1 + (mRect.y2 - mRect.y1) \ 2
                    rr = 5
                    frmMain.picMother.CurrentX = x
                    frmMain.picMother.CurrentY = y
                    frmMain.picMother.Circle (x, y), rr, lngH, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngL, 226 * pi / 180, 45 * pi / 180
                Case 6
                    x = mRect.x1 + (mRect.x2 - mRect.x1) \ 2
                    y = mRect.y1 + (mRect.y2 - mRect.y1) \ 2
                    rr = 5
                    frmMain.picMother.CurrentX = x
                    frmMain.picMother.CurrentY = y
                    frmMain.picMother.Circle (x, y), rr, lngL, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngH, 226 * pi / 180, 45 * pi / 180
                Case 7
                    x = mRect.x1 + (mRect.x2 - mRect.x1) \ 2
                    y = mRect.y1 + (mRect.y2 - mRect.y1) \ 2
                    
                    frmMain.picMother.CurrentX = x
                    frmMain.picMother.CurrentY = y
                    
                    rr = 7
                    frmMain.picMother.Circle (x, y), rr, lngH, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngL, 226 * pi / 180, 45 * pi / 180
                    rr = 3
                    frmMain.picMother.Circle (x, y), rr, lngL, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngH, 226 * pi / 180, 45 * pi / 180
                Case 8
                    x = mRect.x1 + (mRect.x2 - mRect.x1) \ 2
                    y = mRect.y1 + (mRect.y2 - mRect.y1) \ 2
                    
                    frmMain.picMother.CurrentX = x
                    frmMain.picMother.CurrentY = y
                    
                    rr = 7
                    frmMain.picMother.Circle (x, y), rr, lngL, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngH, 226 * pi / 180, 45 * pi / 180
                    rr = 3
                    frmMain.picMother.Circle (x, y), rr, lngH, 45 * pi / 180, 225 * pi / 180
                    frmMain.picMother.Circle (x, y), rr, lngL, 226 * pi / 180, 45 * pi / 180
                End Select
            Else
                mRect.x1 = (i * mW + 1 - mW)
                mRect.y1 = (j * mH + 1 - mH)
                mRect.x2 = (mRect.x1 + mW - 1)
                mRect.y2 = (mRect.y1 + mH - 1)
                frmMain.picMother.Line (mRect.x1, mRect.y1)-(mRect.x2, mRect.y2), RGB(0, 0, 0), BF
            End If
        mOldMotherWork(i, j) = mMotherWork(i, j)
        End If
    Next
  Next
Else
    frmMain.picLittle.Cls
    hh = (frmMain.picLittle.Height \ 15 - GetYSizeL * 13) \ 2
    ww = (frmMain.picLittle.Width \ 15 - GetXSizeL * 13) \ 2
   
   For i = 1 To 4
    For j = 1 To 4
        If mWorkNext(i, j) > 0 Then
            mRect.x1 = 13 * i + 1 - 13 + ww
            mRect.y1 = 13 * j + 1 - 13 + hh
            mRect.x2 = mRect.x1 + 13 - 2
            mRect.y2 = mRect.y1 + 13 - 2
            frmMain.picLittle.Line (mRect.x1, mRect.y1)-(mRect.x2, mRect.y2), mWorkNext(i, j), BF
            frmMain.picLittle.Line (mRect.x2, mRect.y1)-(mRect.x2, mRect.y2), lngL
            frmMain.picLittle.Line (mRect.x1, mRect.y2)-(mRect.x2, mRect.y2), lngL
            frmMain.picLittle.Line (mRect.x1, mRect.y1)-(mRect.x2, mRect.y1), lngH
            frmMain.picLittle.Line (mRect.x1, mRect.y1)-(mRect.x1, mRect.y2), lngH
        End If
    Next
   Next
End If
End Sub

Public Function ScanFullLine() As Long '有无满的行　有则删除
Dim i As Long, j As Long, k As Long, L As Long, r As Long, x As Long
On Error GoTo merr
For j = 1 To mRow '23
    k = 0
    For i = 1 To mLine '10
        If mMotherWork(i, j) > 0 Then k = k + 1
    Next
    If k = mLine Then
        For x = 1 To mLine
            mMotherWork(x, j) = lngL
            paintPic True
            frmMain.picMother.Refresh
            Sleep 10
        Next
        
        r = r + 1
        For L = j To 1 Step -1
            For i = 1 To mLine
                If L > 1 Then mMotherWork(i, L) = mMotherWork(i, L - 1) '往下移
            Next
        Next
    End If
Next

ScanFullLine = r '删除了多少行
Exit Function
merr:
MsgBox Err.Description & "scan"
End Function

Public Function MOVEdown() As Boolean '下移
Dim i As Long, j As Long, Ysize As Long, Xsize As Long

MOVEdown = True
Ysize = GetYSize

If curY + Ysize = mRow Then '已经到底
    MOVEdown = False
    ReDrawPic '重画
    Exit Function
End If

Xsize = GetXSize
For i = 1 To Xsize
    For j = 1 To Ysize
        If (mMotherWork(curX + i, curY + j + 1) > 0) And (mWork(i, j) > 0) Then
            MOVEdown = False
            ReDrawPic '重画
            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, curY + j + 1) = mWork(i, j) '安装数据
        End If
    Next
Next
curY = curY + 1
End Function

Public Function MOVExy(LR As Boolean) As Boolean  'true左移 false右移
Dim i As Long, j As Long, Ysize As Long, Xsize As Long, f As Long

MOVExy = True
Ysize = GetYSize
Xsize = GetXSize

If LR Then
    If curX = 0 Then '最左边
        MOVExy = False
        ReDrawPic '重画
        Exit Function
    End If
    f = -1
Else
    If curX + Xsize = mLine Then '最右边
        MOVExy = False
        ReDrawPic '重画
        Exit Function
    End If
    f = 1
End If

For i = 1 To Xsize
    For j = 1 To Ysize
        If mMotherWork(curX + i + f, curY + j) > 0 And mWork(i, j) > 0 Then
            MOVExy = False
            ReDrawPic '重画
            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 + f, curY + j) = mWork(i, j) '安装数据
        End If
    Next
Next
curX = curX + f
End Function

Public Function Rotate() As Boolean  '转动图形
Dim i As Long, j As Long, k As Long, h As Long, L As Long, Ysize As Long

Rotate = True

If (curY + MAXxy) > mRow Then '下面不够空间
    Rotate = False
    ReDrawPic '重画
    Exit Function
End If

Ysize = GetYSize
SaveOldmWork '保存旧状态

If (curX + Ysize) <= mLine Then '如果转动后不会超出右边界
    If (isTurn(0) = False) Or (isSet(0) = False) Then  '是否可转动 是否可安放
        Rotate = False
        ReDrawPic '重画
        Exit Function
    End If
Else
    L = mLine - curX '离右边界距离
    k = Ysize - L '要向左平移的格数
    If (isTurn(L) = False) Or (isSet(k) = False) Then  '是否可转动 是否可安放
        Rotate = False
        ReDrawPic '重画
        Exit Function
    Else
        curX = curX - k
    End If
End If
End Function

Public Function GetXSizeL() As Long '小图的X轴
Dim i As Long, j As Long
For i = 4 To 1 Step -1
    For j = 1 To 4
        If mWorkNext(i, j) > 0 Then
            GetXSizeL = i
            Exit Function
        End If
    Next
Next
End Function

Public Function GetYSizeL() As Long '小图的Y轴
Dim i As Long, j As Long
For i = 4 To 1 Step -1
    For j = 1 To 4
        If mWorkNext(j, i) > 0 Then
            GetYSizeL = i
            Exit Function
        End If
    Next
Next
End Function

Public Function InsertPic() As Boolean '插入图形
Dim i As Long, j As Long, y As Boolean

curY = 0
curX = mLine \ 2 - 1
InsertPic = True
y = False
For i = 1 To 4
    For j = 1 To 4
        If Not y Then
            If (mWork(i, j) > 0) And (mMotherWork(curX + i, curY + j) > 0) Then
                InsertPic = False '游戏结束！
                y = True