frmmain.frm

使用VB编写的一个小游戏——具体的自己进去看

         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   3000
      TabIndex        =   5
      Top             =   2160
      Width           =   1455
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "高度"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   12
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000040C0&
      Height          =   240
      Left            =   3000
      TabIndex        =   4
      Top             =   1920
      Width           =   525
   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 Sub cmdPause_Click()
isPuse = Not isPuse
If isPuse Then
    Timer1.Enabled = False
    isStart = False
Else
    Timer1.Enabled = True
    isStart = True
End If
Me.SetFocus
SetlblFlash (3)
End Sub

Private Sub cmdStop_Click()
Timer1.Enabled = False
cmdStart.Enabled = True
cmdPause.Enabled = False
cmdStop.Enabled = False
Frame3.Enabled = True

isStart = False
Me.SetFocus
'===
picMother.Cls
SetlblFlash (4) 'stop
End Sub

Private Sub Form_Load()
appPath = App.Path
If Right(appPath, 1) <> "\" Then
    appPath = appPath & "\"
End If
frmInit
End Sub

Private Sub frmInit()
Dim L As Long



If Option1.Value = True Then
    mLine = 10
    mRow = 23
    mPicNum = 7
ElseIf Option2.Value = True Then
        mLine = 12
        mRow = 24
        mPicNum = 7
ElseIf Option3.Value = True Then
        mLine = 14
        mRow = 25
        mPicNum = 11
End If

If Option4.Value = True Then
    mBase = 400
ElseIf Option5.Value = True Then
        mBase = 300
ElseIf Option6.Value = True Then
        mBase = 200
End If

If Option7.Value = True Then
    mLineHigh = 0
ElseIf Option8.Value = True Then
        mLineHigh = 5
ElseIf Option9.Value = True Then
        mLineHigh = 12
End If
    
With picMother
    .Height = mH * 15 * mRow
    .Width = mW * 15 * mLine
End With
With Frame1
    .Height = picMother.Height \ 15 + 25
    .Width = picMother.Width \ 15 + 18
End With
Select Case mPicNum
    Case 7
    L = 4
    Case 11
    L = 6
End Select
With picLittle
    .Height = 13 * 15 * L
    .Width = 13 * 15 * 6
End With
With Frame2
    .Left = Frame1.Left + Frame1.Width + 15
    .Height = picLittle.Height \ 15 + 25
    .Width = picLittle.Width \ 15 + 18
End With

Label1.Left = Frame2.Left
Label2.Left = Label1.Left
Label3.Left = Label1.Left
Label4.Left = Label1.Left
lblLevel.Left = Label1.Left
lblLine.Left = Label1.Left
lblRecord.Left = Label1.Left
lblCurRecord.Left = Label1.Left
cmdStart.Left = Label1.Left
cmdPause.Left = Label1.Left
cmdStop.Left = cmdPause.Left + cmdPause.Width - 1
Frame3.Left = Label1.Left

cmdPause.Top = Frame1.Top + Frame1.Height - cmdPause.Height
cmdStart.Top = cmdPause.Top - cmdPause.Height + 1
cmdStop.Top = cmdPause.Top

frmMain.Height = Frame1.Height * 15 + 800
frmMain.Width = Frame2.Left * 15 + Frame2.Width * 15 + 250

lngH = RGB(255, 255, 255)
lngL = RGB(0, 0, 0)

cmdStart.Enabled = True
cmdPause.Enabled = False
cmdStop.Enabled = False

Me.Left = (Screen.Width - Me.Width) / 2
Me.Top = (Screen.Height - Me.Height) / 2

frmMain.picMother.Cls
frmMain.picLittle.Cls
SetlblFlash (1)

isStart = False '游戏未开始不能按键
End Sub

Private Sub cmdStart_Click()
Erase mWork
Erase mWorkNext
Erase mOldWork
ReDim mMotherWork(1 To mLine, 1 To mRow)
ReDim mOldMotherWork(1 To mLine, 1 To mRow)
picMother.Cls

isKeyBusy = False
isPuse = False
isInsertPic = True
isKeySpace = False
isRePaint = False
GameIsOver = False

cmdStart.Enabled = False
cmdPause.Enabled = True
cmdStop.Enabled = True
Frame3.Enabled = False
lblLevel = 0
lblLine = 0
lblRecord = 0
lblCurRecord = 0
SelectTypeRecord = 0

Me.SetFocus

initColor
initPic
initColor
initPic
InsertPic
paintPic (False)
paintPic (True)

'选择一种图形
SelectType
CheckLineHigh '设置行高

SetlblFlash (2)

isStart = True
Timer1.Interval = mBase
Timer1.Enabled = True
End Sub

Private Sub CheckLineHigh() '设置行高
Dim i As Long, j As Long, r As Long

If mLineHigh = 0 Then Exit Sub
Randomize
For j = mRow To mRow - mLineHigh 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
Next
'frmMain.picMother.Cls
paintPic True
End Sub

Private Sub Option1_Click()
frmInit
End Sub

Private Sub Option2_Click()
frmInit
End Sub

Private Sub Option3_Click()
frmInit
End Sub

Private Sub Option4_Click()
frmInit
End Sub

Private Sub Option5_Click()
frmInit
End Sub

Private Sub Option6_Click()
frmInit
End Sub

Private Sub Option7_Click()
frmInit
End Sub

Private Sub Option8_Click()
frmInit
End Sub

Private Sub Option9_Click()
frmInit
End Sub

Private Sub Timer1_Timer()
On Error GoTo merr

Timer1.Enabled = False
'paintPic (True)

ClearPic
If Not MOVEdown Then
    DoNext
End If
paintPic (True)

If (Not isInsertPic) Or GameIsOver Then
    paintPic True
    GameOver '游戏结束!
Else
    Timer1.Enabled = True
End If
Exit Sub
merr:
'MsgBox "timer"
    Timer1.Interval = 50
End Sub

Private Sub DoNext()
Dim r As Long, L As Long
Dim h As Long
On Error GoTo merr
    paintPic (True)
    If isKeySpace Then '加速加倍分
        h = 2
        isKeySpace = False
    Else
        h = 1
    End If
    
    L = CurL '取得当前行高
    lblLine = L
    
    r = ScanFullLine
    If r = 4 Then
        r = 1000 '一次删除四行
    Else
        r = r * 100 '=====
    End If
    lblCurRecord = (r + L * 2) * h '快速下则加倍分
    lblRecord = CLng(lblRecord) + CLng(lblCurRecord)
    
    r = lblRecord \ mSelectLineType
    If r > SelectTypeRecord Then
        SelectType '选择一种图形
        SelectTypeRecord = r
    End If
    
    r = lblRecord \ mAddLine
    If r > CLng(lblLevel) Then '升一级
        CheckType '如果是中高级则每升一级底加一行
        lblLevel = CLng(lblLevel) + r
        Timer1.Interval = Timer1.Interval - 30
        If Timer1.Interval < 50 Then Timer1.Interval = 50
        lblLevel = r
    End If

    GameIsOver = CheckGameOver '是否已结束

    initColor
    initPic
    isInsertPic = InsertPic
    paintPic False
Exit Sub
merr:
'MsgBox Err.Description & "donext"
    Timer1.Interval = 50
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If isStart = False Then Exit Sub
If isKeyDown = True Then Exit Sub
If KeyCode <> vbKeyLeft And KeyCode <> vbKeyRight And KeyCode <> vbKeyUp _
    And KeyCode <> vbKeyDown And KeyCode <> vbKeySpace Then Exit Sub
    
If isKeyBusy Then
    Exit Sub
Else
    isKeyBusy = True
End If

ClearPic
Select Case KeyCode
    Case vbKeyLeft
        MOVExy True
    Case vbKeyRight
        MOVExy False
    Case vbKeyUp
        Rotate
    Case vbKeyDown
        If Not isKeyDown Then
            Timer1.Enabled = False
            isKeyDown = True
            OldIntervalDown = Timer1.Interval '保存旧值
            Timer1.Interval = 10
            Timer1.Enabled = True
        End If
    Case vbKeySpace
        isKeySpace = True
        While MOVEdown
            ClearPic
            paintPic (True)
        Wend
        DoNext
End Select

paintPic True

isKeyBusy = False
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
If isStart = False Then Exit Sub
Select Case KeyCode
    Case vbKeyDown
        isKeyDown = False
        Timer1.Interval = OldIntervalDown
End Select
End Sub

Private Sub GameOver()
Dim i As Long, j As Long

Timer1.Enabled = False
cmdStart.Enabled = False
cmdPause.Enabled = False
cmdStop.Enabled = False
GetRecord CLng(lblRecord.Caption)  '检查能否有名次

isRePaint = True
Randomize
For j = mRow To 1 Step -1
    For i = 1 To mLine
        mMotherWork(i, j) = QBColor(CLng(Int(Rnd * (14 - 8 + 1) + 8)))
    Next
    'DoEvents
    paintPic True
    'LineType = CLng(Int(Rnd * 9))
    picMother.Refresh
    Sleep 30
Next
isStart = False
picMother.Cls
SetlblFlash (5)
cmdStart.Enabled = True
Frame3.Enabled = True
End Sub

Private Sub SetlblFlash(n As Long)  '设置flash
Select Case n
    Case 1
        lblFlash = "Game Start"
        lblFlash.Visible = True
        lblreadme.Visible = True
    Case 2
        lblFlash.Visible = False '开始游戏
        lblreadme.Visible = False
    Case 3
        lblFlash = "Game Puse"
        lblFlash.Visible = Not lblFlash.Visible
        lblreadme.Visible = Not lblreadme.Visible
    Case 4
        lblFlash = "Game Stop"
        lblFlash.Visible = True
        lblreadme.Visible = True
    Case 5
        lblFlash = "Game Over"
        lblFlash.Visible = True
        lblreadme.Visible = True
End Select
lblFlash.Left = (Frame1.Width - lblFlash.Width) \ 2
lblFlash.Top = Frame1.Height \ 4
lblreadme.Left = (Frame1.Width - lblreadme.Width) \ 2 - 10
lblreadme.Top = Frame1.Height - 70
End Sub