| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 4113 人关注过本帖
标题:我也开新贴吧
取消只看楼主 加入收藏
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
结帖率:100%
收藏
 问题点数:0 回复次数:7 
我也开新贴吧
原问题讨论:
https://bbs.bccn.net/thread-465198-1-1.html
新贴:
https://bbs.bccn.net/thread-465341-1-1.html

我的电脑:AMD:7800,8G
我的代码:爆炸难度:40FPS,我对这个结果很满意了。

全VB6代码绘图,未使用 API ,主要原因是不太熟悉这块。
如果点由图像贴图的话,只需要改 显示函数就可以了,直接贴图就行了。

------BAS 文件-----
程序代码:
Option Explicit

Public Type Dtype
    X As Long
    Y As Long
    R As Long
    C As Long
    Speed As Long
    HP As Long
End Type

Public Enum GameModeEnum
    gamestop = 0
    gamerun = 1
    GamePause = 2
    GameMin = 3
End Enum

Public MaxX As Long, MaxY As Long       '最大坐标

Public GameMode As GameModeEnum

Public LdStr(3) As String
Public LdN As Long

Public Score  As Long

Public dian() As Dtype
Public JValue As Long

Public DDian As Dtype      '大点
Public DM(1) As Long       '大点移动,0:X,1:Y
Public Const DDR = 10           '大点半径,以像素 为单位
Public Const DdC = 65280        '大点颜色 ,65280=绿色 ,使用立即窗口用 RGB函数查询

Public TX As Long               'Screen.TwipsPerPixelX
Public FPS As Long

Public TI As Single             '游戏最后一个运行回合的时间
;---------------代码开始---------------
Public Sub NewDian(Cs As Dtype)
With Cs
Dim i As Long
i = DDR * 10 * TX           '多少半径的空位
Do
    .X = Int(Rnd() * MaxX)
    .Y = Int(Rnd() * MaxY)
Loop While Abs(.X - DDian.X) < i And Abs(.Y - DDian.Y) < i              '如果有大点周围,重新去产生位置
    
    .HP = Int(Rnd() * 100) + 1        '存活周期 1-100 ,定时器是100,100就是10秒
    .R = (Int(Rnd() * 4) + 2) * TX         '点的半径,1-4像素
    .Speed = Int(Rnd() * 3 + 1) * TX        '点移动速度
    
'颜色还可以根据大小+速度来设定。这里仅仅演示使用速度
    Select Case .Speed              '4种速度对应的颜色,可以使用 RGB函数取不同的颜色
        Case TX
            .C = 64
        Case TX * 2
            .C = 128
        Case TX * 3
            .C = 192
        Case TX * 4
            .C = 255
    End Select
End With
End Sub


------窗体代码-------
程序代码:
Option Explicit
'凡有结构体的,我习惯把结构做放到模块中,所以这里没有了定义

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
'按键暂停和取消,防止 Picture1 中没触发到
If KeyCode = 32 Or KeyCode = 27 Then
    If GameMode = GamePause Then
        GameMode = gamerun
    ElseIf GameMode = gamerun Then
        GameMode = GamePause
    End If
End If
End Sub

Private Sub Form_Load()

'游戏状态为停止
GameMode = gamestop

'最大化窗体
Form1.WindowState = vbMaximized

'缓冲区需要持久性位图
Picture3.AutoRedraw = True

'显示区需要快速显示,不需要持久性位图
Picture1.AutoRedraw = False

'初始化随机函数发生器
Randomize

'四个难度名字,显示标题栏用
LdStr(0) = "简单"
LdStr(1) = "普通"
LdStr(2) = "困难"
LdStr(3) = "爆炸难度"

'像素与缇的比例,这里只取 X轴,
TX = Screen.TwipsPerPixelX

End Sub

Private Sub Form_Resize()

If Form1.WindowState = vbMinimized Then     '最小化时暂停
    If GameMode = gamerun Then
        GameMode = GameMin                  '设置当前模式为最小化,游戏自动暂停
    End If
    Exit Sub
End If

'最大化游戏区域
Picture1.Move 120, 120, Me.ScaleWidth - 240, Me.ScaleHeight - 120

'保存显示区域最大值
MaxX = Picture1.ScaleWidth
MaxY = Picture1.ScaleHeight

'选单居中
Picture2.Move (MaxX - Picture2.Width) / 2, (MaxY - Picture2.Height) / 2

'缓冲区,需要与显示区一样大
Picture3.Move Picture1.Left, Picture1.Top, Picture1.Width, Picture1.Height

'如果游戏是从最小化状态恢复的,自动继续运行
If GameMode = GameMin Then
    GameMode = gamerun
End If

End Sub

Private Sub Label2_Click(Index As Integer)

LdN = Index     '保存难度等级

'各个难度对应点的数量
Select Case Index
Case 0
    JValue = 100
Case 1
    JValue = 300
Case 2
    JValue = 600
Case 3
    JValue = 1000
End Select

ReDim dian(JValue)              '保存点数组

Picture2.Visible = False        '隐藏选单

DDian.X = MaxX / 2              '大点先放在窗体中央
DDian.Y = MaxY / 2
DDian.C = DdC
DDian.R = DDR * TX

Dim i As Long
For i = 0 To JValue
    Call NewDian(dian(i))       '生成每个点的数据
Next i

Score = 0
TI = Timer                      '保存第一次回合前的时间
Timer1.Enabled = True           '开定时器
Timer2.Enabled = True           '其实这二个定时器,都应该默认为开启的
GameMode = gamerun              '设置游戏状态为运行

End Sub

Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = 32 Or KeyCode = 27 Then        '按下空格键时
    If GameMode = GamePause Then            '暂停状态
        GameMode = gamerun                  '改为运行状态
    ElseIf GameMode = gamerun Then          '运行状态
        GameMode = GamePause                '改为暂停状态
    End If
End If
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If GameMode = gamestop Then         '游戏处于结束状态,按下鼠标时显示开始选单
    Picture2.Visible = True
End If

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'保存鼠标位置,点的位置,通过
DM(0) = X
DM(1) = Y

End Sub

Public Sub view(obj As PictureBox)
'只有处于游戏运行状态,才需要绘图,否则直接显示缓冲区图像就可以了。
If GameMode = gamerun Then

    obj.Cls
    
    Dim i As Long
    Dim j As Long
    Dim R As Long
    
    '线条宽 1 像素
    obj.DrawWidth = 1
    
    '先画大点
    With DDian
    For j = 1 To .R Step TX
        obj.Circle (.X, .Y), j, DdC
    Next j
    End With
    
    '再画小点
    For i = 1 To JValue
    With dian(i)
    '使用画同心圆的方式得到实心圆
    '    obj.Circle (.X, .Y), .R, .C
    For j = 1 To .R Step TX
        obj.Circle (.X, .Y), j, .C
    Next j
       
    End With
    Next i

End If

End Sub

Private Sub Picture1_Paint()
'系统需要重绘时,直接复制缓冲区图像。如被对话框覆盖清掉了的时候

    Picture1.PaintPicture Picture3.Image, 0, 0

End Sub

Private Sub Timer1_Timer()

FPS = FPS + 1

If Timer - TI > 0 And Timer - TI < 0.1 Then  '游戏每回合时间,0.1 代表 0.1秒
'注意,过天时判断会有忽略一次时间间隔BUG,不影响游戏运行
    Exit Sub
End If
TI = Timer

If GameMode <> gamerun Then             '如果不是处在运行状态,则退出定时器
    Exit Sub
End If

Dim i As Long
Dim GameEnd As Boolean
GameEnd = False

'按鼠标位置移动大点,大点的速度是大点的半径
'i = DDR * TX
'With DDian
'If DM(0) - .X > i Then
'    .X = .X + i
'ElseIf .X - DM(0) > i Then
'    .X = .X - i
'Else
'    .X = DM(0)
'End If
'
'If DM(1) - .Y > i Then
'    .Y = .Y + i
'ElseIf .Y - DM(1) > i Then
'    .Y = .Y - i
'Else
'    .Y = DM(1)
'End If
'End With

'大点直接在鼠标下面
DDian.X = DM(0)
DDian.Y = DM(1)

For i = 1 To JValue
With dian(i)
    If Abs(.X - DDian.X) < DDian.R And Abs(.Y - DDian.Y) < DDian.R Then
        '结束
        GameEnd = True
        '因为需要绘制最终的图像,所以不能在这里直接切换为结束游戏,需要等这个回合结束
    End If

    '按大点方位移动小点,移动X,Y方向移动距离最大情况是相同的
    If .X - DDian.X > .Speed Then               '距离超过 速度
        .X = .X - .Speed                        '移动速度
    ElseIf DDian.X - .X > .Speed Then           '距离反方向超过速度
        .X = .X + .Speed                        '移动速度
    Else
        .X = DDian.X                            '否则移动到目标位置
    End If
    
    If .Y - DDian.Y > .Speed Then
        .Y = .Y - .Speed
    ElseIf DDian.Y - .Y > .Speed Then
        .Y = .Y + .Speed
    Else
        .Y = DDian.Y
    End If
       
    .HP = .HP - 1                       '生命-1
    If .HP = 0 Then                     '如果生命为0
        Call NewDian(dian(i))           '重新产生一个新点
    End If
    
End With
Next i

Call view(Picture3)                         '绘图到缓冲区
Picture1.PaintPicture Picture3.Image, 0, 0  '把缓冲区的图像显示出来

If GameEnd Then
    GameMode = gamestop
    MsgBox "游戏结束" & vbCrLf & "得分:" & Score, vbInformation, "游戏结束"
    '调用写记录事件,这里省略,需要补

End If

End Sub

Private Sub Timer2_Timer()

Select Case GameMode
    Case gamerun                '运行状态,按1秒1分进行 计分
        Score = Score + LdN + 1
        Me.Caption = "躲避点-难度:" & LdStr(LdN) & " 得分:" & Score & "  FPS: " & FPS
        FPS = 0
    Case GameMin                '游戏最小化时,直接暂停,不需要处理
    Case gamestop               '游戏结束状态
        Me.Caption = "躲避点-结束 FPS: " & FPS
        FPS = 0
    Case GamePause              '游戏暂停状态,需要提示暂停
        Me.Caption = "躲避点-难度:" & LdStr(LdN) & " 得分:" & Score & " 暂停 FPS: " & FPS
        FPS = 0
End Select

End Sub


整个工程:
点游戏.rar (11.9 KB)
2016-05-28 21:34
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
图片附件: 游客没有浏览图片的权限,请 登录注册

授人于鱼,不如授人于渔
早已停用QQ了
2016-05-28 21:36
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
我仔细看了你的第二个程序的流程。
定时器代码问题。
定时器里,不要再使用 DoEvents 命令。该命令会导致VB暂停当前定时器代码,而去响应新的定时器代码。
造成堆栈里全是这个TIMER1定时器的处理过程,然后游戏结束后,没有了新的事件,然后就继续处理堆栈中的这些代码,
这些代码是放在 FROM2 中的,就会造成 Form2 的隐性加载。


[此贴子已经被作者于2016-5-29 17:58编辑过]


授人于鱼,不如授人于渔
早已停用QQ了
2016-05-29 17:52
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
我仔细看了你的第二个程序的流程。
定时器代码问题。
定时器里,不要再使用 DoEvents 命令。该命令会导致VB暂停当前定时器代码,而去响应新的定时器代码。
造成堆栈里全是这个TIMER1定时器的处理过程,然后游戏结束后,没有了新的事件,然后就继续处理堆栈中的这些代码,
这些代码是放在 FROM2 中的,就会造成 Form2 的隐性加载。

授人于鱼,不如授人于渔
早已停用QQ了
2016-05-29 17:58
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
Form2 代码中:
Private Sub Timer3_Timer()
这行改成:
Public Sub startgame()
同时去掉这个过程中最后一句,
Timer3.Enabled = False
删掉 Timer3 这个控件。

Form1 代码中:
Form2.Show
Call Form2.startgame            '加一句手动调用
Unload Me

------------------
FPS:肯定是游戏中段肯定稳定的,在游戏刚开始那下是比较低,然后稳定到正常水平,结束时,对应框显示时,FPS 会掉到 0 去。
如果不关掉FORM2 的话,就可以看到 FPS 会稳定在一个很高的水平,我自己电脑是可以达到 65 以上。

-------------------
你的 Difficulty 是从1-4,而我的名字数组是从 0-3 ,所以这段代码里需要 减 1 。
另外,计分,可以根据难度来计分。这句        Score = Score + 1   你可以按难度变化。

程序代码:
Private Sub Timer2_Timer()

Select Case GameMode
    Case Gamerun                '运行状态,按1秒2分进行 计分
        Score = Score + 1
        Me.Caption = "反应速度测试-难度:" & LdStr(Difficulty - 1) & " 得分:" & Score & "  FPS: " & FPS
        FPS = 0
    Case GameMin                '游戏最小化时,直接暂停,不需要处理
    Case Gamestop               '游戏结束状态
        Me.Caption = "反应速度测试-结束 FPS: " & FPS
        FPS = 0
    Case GamePause              '游戏暂停状态,需要提示暂停
        Me.Caption = "反应速度测试-难度:" & LdStr(Difficulty - 1) & " 得分:" & Score & " 暂停 FPS: " & FPS
        FPS = 0
End Select
End Sub


[此贴子已经被作者于2016-5-30 17:46编辑过]


授人于鱼,不如授人于渔
早已停用QQ了
2016-05-30 17:23
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
保存记录,不要用你那么复杂的方法,四个数值,竟然保存在四个文件里。
程序代码:
If GameEnd Then
    GameMode = Gamestop
    
    Dim s As String                     '记录文件
    Dim m(3) As Long                    '4个记录,按顺序来。0号是简单,1号是普通,2困难,3是爆炸,与 Difficulty 变量值对应
    Dim fr As Long                      '文件号
    
    s = App.Path                        '取程序路径
    If Right(s, 1) <> "\" Then          '根据程序路径最后是否存在 \ 符号,生成存盘文件名
        s = s & "\Score.sav"
    Else
        s = s & "Score.sav"
    End If
    
    fr = FreeFile                       '取空闲文件号,防止出错
    If Dir(s) <> "" Then                '文件存在
        Open s For Binary As #fr        '打开文件
            Get #fr, , m                '一次性读四个值,这里文件如果损坏,会导致程序报错,需要处理,这里省略,自己想。
        Close fr
    End If
    
    If Score > m(Difficulty - 1) Then   '如果破了指定难度的记录
        m(Difficulty - 1) = Score       '保存记录
        Open s For Binary As #fr        '打开文件
            Put #fr, , m                '写入记录
        Close fr
        MsgBox "你死了!游戏结束!你的分数是最高纪录!分数:" & CStr(Score)
    Else
        MsgBox "你死了!游戏结束!未破纪录。分数:" & CStr(Score)
    End If
    Form1.Show '显示开始界面
    Unload Me '卸载窗体
    Exit Sub
    
End If


Form3 的代码
程序代码:
Private Sub Form_Load()
Dim a As String
On Error Resume Next '无纪录依然可以显示

    Dim s As String
    Dim m(3) As Long
    Dim fr As Long
    
    s = App.Path
    If Right(s, 1) <> "\" Then
        s = s & "\Score.sav"
    Else
        s = s & "Score.sav"
    End If
    
    fr = FreeFile
    If Dir(s) <> "" Then
        Open s For Binary As #fr
            Get #fr, , m
        Close fr
    End If

Label1.Caption = m(0)
Label2.Caption = m(1)
Label3.Caption = m(2)
Label4.Caption = m(3)
End Sub


授人于鱼,不如授人于渔
早已停用QQ了
2016-05-30 17:42
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
难以至信的优化结果:
100000 个点,我的电脑达到了 32 FPS
再增加点,立即报错,感觉是数组占用的内存爆掉了。

优化方向,干掉 Circle 方法,而使用直接操作内存写入数据来生成图形的方法。
现在带来的后果就是 生成的圆,有毛刺,有点像的头样的。

现在就是一个问题,程序稳定性比较差,正在努力中。

----------------
照例,因多线程主体框架不是我的,所以只传编译后的文件。CPU占用率40%
VBMT.rar (10.93 KB)


------------去掉结束游戏那部分判断代码抓图测试代码----------------
图片附件: 游客没有浏览图片的权限,请 登录注册


[此贴子已经被作者于2016-5-30 22:06编辑过]


授人于鱼,不如授人于渔
早已停用QQ了
2016-05-30 21:53
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:0 
回复 17楼 八云
源码在这: https://bbs.bccn.net/thread-481230-1-1.html

授人于鱼,不如授人于渔
早已停用QQ了
2018-05-10 22:21
快速回复:我也开新贴吧
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.036109 second(s), 10 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved