VB6实现注意力实验代码

VB6代码如下：

' 实验常量

Const DISPLAY_WIDTH_CM As Single = 12.7

Const DISPLAY_HEIGHT_CM As Single = 15.5

Const CENTER_Y As Single = 7.75 ' 中线Y坐标 (15.5 / 2)

Const OBJECT_SIZE As Single = 1# ' 物体大小 (1cm x 1cm)

Const MAX_SPEED As Single = 1# ' 最大速度 (cm/s)

Const MIN_SPEED As Single = 0.5 ' 最小速度 (cm/s)

Const TRIAL_DURATION As Integer = 15

Const UNEXPECTED_DURATION As Integer = 5 ' 意外刺激持续时间 (秒)

Private m_PracticeCorrectCount As Integer

' 实验状态

Enum TrialPhase

Learning

Practice

MainTrial

End Enum

Enum TrialType

Standard

Critical

DividedAttention

FullAttention

End Enum

' 物体类型

Private Type MovingObject

x As Single ' X坐标 (cm)

y As Single ' Y坐标 (cm)

vx As Single ' X速度 (cm/s)

vy As Single ' Y速度 (cm/s)

objType As String ' 物体类型: "L", "T", "+"

color As Long ' 颜色

isTarget As Boolean ' 是否是目标(黑色)

isVisible As Boolean ' 是否可见

End Type

' 实验变量

Private m_Phase As TrialPhase

Private m_TrialType As TrialType

Private m_TrialNumber As Integer

Private m_TrialStartTime As Double

Private m_TrialTime As Single

Private m_Objects(1 To 8) As MovingObject ' 8个移动物体

Private m_Unexpected As MovingObject ' 意外刺激

Private m_TouchCount As Integer ' 触碰次数计数

Private m_ResponseTime As Double ' 响应时间

Private m_UnexpectedVisible As Boolean ' 意外刺激是否可见

Private m_CentralCondition As Long ' 意外刺激位置条件 (True=中央, False=外周)

' 修改位置条件枚举

Enum PositionCondition

Central = 1

UpperPeripheral = 2

LowerPeripheral = 3

End Enum

' 设置显示

Private Sub SetupDisplay()

' 设置显示区域为12.7cm x 15.5cm

picScreen.Scale (0, 0)-(DISPLAY_WIDTH_CM, DISPLAY_HEIGHT_CM)

picScreen.BackColor = RGB(128, 128, 128) ' 灰色背景 (约32.1 cd/m2)

DrawCenterLine

End Sub

' 绘制中心线和注视点

Private Sub DrawCenterLine()

picScreen.Line (0, CENTER_Y)-(DISPLAY_WIDTH_CM, CENTER_Y), vbBlue

' 绘制注视点 (中心点)

picScreen.FillColor = vbBlue

picScreen.FillStyle = 0

picScreen.Circle (DISPLAY_WIDTH_CM / 2, CENTER_Y), 0.1, vbBlue

End Sub

' 显示实验说明

Private Sub ShowInstructions()

Dim msg As String

msg = "欢迎参加注意力实验!" & vbCrLf & vbCrLf

msg = msg & "实验要求：" & vbCrLf

msg = msg & "1. 请将注意力集中在屏幕中心的蓝色注视点" & vbCrLf

msg = msg & "2. 记录黑色形状触碰中心线的次数" & vbCrLf

msg = msg & "3. 每次试次结束后输入记录的次数" & vbCrLf & vbCrLf

msg = msg & "按空格键开始练习阶段"

MsgBox msg, vbInformation, "实验说明"

m_Phase = Practice

m_TrialNumber = 0

End Sub

' 结束当前试次 (修改后的部分)

Private Sub EndTrial()

tmrMain.Enabled = False

' 记录触碰次数

Dim response As String

Dim correctResponse As Boolean

If m_TouchCount > 0 Then

response = InputBox("请输入黑色形状触碰中线的次数：", "试次结束", "")

' 检查回答是否正确

correctResponse = (Val(response) = m_TouchCount)

' 根据阶段处理结果

Select Case m_Phase

Case Practice

If correctResponse Then

m_PracticeCorrectCount = m_PracticeCorrectCount + 1

MsgBox "正确", , "完成"

Else

m_PracticeCorrectCount = 0 ' 任何一次错误重置计数器

MsgBox "正确答案是：" & m_TouchCount, , "完成"

End If

Case MainTrial

If correctResponse Then

MsgBox "正确", , "完成"

Else

MsgBox "正确答案是：" & m_TouchCount, , "完成"

End If

End Select

End If

' 特殊试次需要报告意外刺激和位置识别

If m_Phase = MainTrial And (m_TrialType = Critical Or m_TrialType = DividedAttention Or m_TrialType = FullAttention) Then

Dim seen As String

seen = InputBox("除了黑白的L和T之外，您还看到其他东西了吗？(y/n)", "请回答问题")

If UCase(seen) = "Y" Then

Dim desc As String

desc = InputBox("如果看到了，请描述它是什么：", "请回答问题")

' +++ 新增：位置识别问题 +++

Dim posAnswer As String

posAnswer = InputBox("您看到的这个物体出现在屏幕的什么位置？" & vbCrLf & _

"1. 中央位置 (靠近蓝色中线)" & vbCrLf & _

"2. 水平线上方位置" & vbCrLf & _

"3. 水平线下方位置")

' 检查位置识别是否正确

Dim actualPosition As String

Dim userCorrect As Boolean

' 检查位置识别是否正确

' 检查位置识别是否正确

If m_CentralCondition = Central Then

actualPosition = "中央位置 (在水平线上)"

userCorrect = (posAnswer = "1")

ElseIf m_CentralCondition = UpperPeripheral Then

actualPosition = "水平线上方位置"

userCorrect = (posAnswer = "2")

ElseIf m_CentralCondition = LowerPeripheral Then

actualPosition = "水平线下方位置"

userCorrect = (posAnswer = "3")

End If

' 额外验证：如果物体实际在水平线上，强制设为中央位置

If IsOnCenterLine(m_Unexpected.y) Then

actualPosition = "中央位置 (在水平线上)"

userCorrect = (posAnswer = "1")

End If

' 提供反馈

If userCorrect Then

MsgBox "正确！物体确实出现在" & actualPosition & "。", vbInformation, "位置识别正确"

Else

MsgBox "不正确。物体实际出现在" & actualPosition & "。", vbExclamation, "位置识别"

End If

' +++ 结束新增 +++

End If

End If

' 确定下一个试次 (修改后的流程控制)

Select Case m_Phase

Case Practice

' 检查是否完成3次正确练习

If m_PracticeCorrectCount >= 3 Then

MsgBox "练习阶段完成，现在开始正式实验。", vbInformation, "练习通过"

m_Phase = MainTrial

m_TrialNumber = 0

StartTrial Standard

Else

' 继续练习直到3次正确

StartTrial Standard

End If

Case MainTrial

' 正式实验共5次

Select Case m_TrialNumber

Case 1

StartTrial Standard ' 前两次没有+号

Case 2

StartTrial Critical ' 第三次出现+号

Case 3

StartTrial DividedAttention ' 第四次出现+号

Case 4

StartTrial FullAttention ' 第五次出现+号

Case Else

MsgBox "实验完成！", vbInformation

Unload Me

End Select

End Select

End Sub

' 验证物体是否在水平线上

Private Function IsOnCenterLine(y As Single) As Boolean

' 允许0.1cm的误差范围

IsOnCenterLine = (Abs(y - CENTER_Y) < 0.1)

End Function

' 显示意外刺激

Private Sub ShowUnexpected()

m_UnexpectedVisible = True

m_Unexpected.isVisible = True

m_Unexpected.x = DISPLAY_WIDTH_CM + 1 ' 从右侧进入

' 设置Y位置 (根据实验条件)

Select Case m_CentralCondition

Case Central

m_Unexpected.y = CENTER_Y ' 中央位置 (在水平线上)

Case UpperPeripheral

m_Unexpected.y = CENTER_Y - 5.9 ' 上方位置 (离水平线5.9cm)

Case LowerPeripheral

m_Unexpected.y = CENTER_Y + 5.9 ' 下方位置 (离水平线5.9cm)

End Select

' 确保意外刺激在屏幕范围内

If m_Unexpected.y < 2.25 Then m_Unexpected.y = 2.25

If m_Unexpected.y > DISPLAY_HEIGHT_CM - 2.25 Then m_Unexpected.y = DISPLAY_HEIGHT_CM - 2.25

End Sub

' 开始新试次 (添加了意外刺激位置随机化)

Private Sub StartTrial(tType As TrialType)

m_TrialType = tType

m_TrialNumber = m_TrialNumber + 1

m_TrialStartTime = Timer

m_TrialTime = 0

m_TouchCount = 0

m_UnexpectedVisible = False

' 随机化意外刺激位置 (1/3概率每个位置)

Dim posRand As Single

posRand = Rnd

Select Case posRand

Case Is < 0.333

m_CentralCondition = Central

Case Is < 0.666

m_CentralCondition = UpperPeripheral

Case Else

m_CentralCondition = LowerPeripheral

End Select

' 初始化移动物体

InitializeObjects

' 特殊试次提示

Select Case m_TrialType

Case DividedAttention

' 正式实验最后三次的提示

MsgBox "接下来，你在记录黑色形状触碰中线次数的同时，要注意是否有其他的东西和这些形状一起出现。", vbInformation, "注意"

Case FullAttention

MsgBox "接下来，你只需观察是否有其他的东西和黑白形状一起出现，不需要记录触碰中线的次数。", vbInformation, "注意"

End Select

tmrMain.Enabled = True

End Sub

' 初始化移动物体

Private Sub InitializeObjects()

Dim i As Integer

Dim speed As Single, angle As Single

' 初始化8个物体 (4黑4白, L和T各4个)

For i = 1 To 8

' 随机位置 (在有效区域内)

m_Objects(i).x = Rnd * DISPLAY_WIDTH_CM

m_Objects(i).y = 2.25 + Rnd * (13.25 - 2.25) ' 2.25-13.25cm范围

' 随机速度 (2-5 cm/s)

speed = MIN_SPEED + Rnd * (MAX_SPEED - MIN_SPEED)

angle = Rnd * 2 * 3.14159

m_Objects(i).vx = speed * Cos(angle)

m_Objects(i).vy = speed * Sin(angle)

' 设置物体类型和颜色

If i <= 4 Then ' 前4个是黑色

m_Objects(i).color = RGB(0, 0, 0) ' 黑色 (1.2 cd/m2)

m_Objects(i).isTarget = True

Else ' 后4个是白色

m_Objects(i).color = RGB(255, 255, 255) ' 白色 (88.0 cd/m2)

m_Objects(i).isTarget = False

End If

' 分配L和T形状 (各4个)

If i Mod 2 = 0 Then

m_Objects(i).objType = "L"

Else

m_Objects(i).objType = "T"

End If

m_Objects(i).isVisible = True

Next i

' 初始化意外刺激

m_Unexpected.objType = "+"

m_Unexpected.color = RGB(180, 180, 180) ' 浅灰色 (49.3 cd/m2)

m_Unexpected.isTarget = False

m_Unexpected.isVisible = False

End Sub

' 主计时器循环

Private Sub tmrMain_Timer()

m_TrialTime = Timer - m_TrialStartTime

' 检查试次是否结束 (15秒)

If m_TrialTime >= TRIAL_DURATION Then

EndTrial

Exit Sub

End If

' 更新物体位置

UpdateObjects

' 检查是否需要显示意外刺激

If (m_TrialType = Critical Or m_TrialType = DividedAttention Or m_TrialType = FullAttention) And _

m_TrialTime >= 5 And m_TrialTime <= 10 And Not m_UnexpectedVisible Then

ShowUnexpected

End If

' 重绘屏幕

DrawScene

End Sub

' 更新物体位置

Private Sub UpdateObjects()

Dim i As Integer

Dim nextX As Single, nextY As Single

For i = 1 To 8

If m_Objects(i).isVisible Then

' 计算下一位置

nextX = m_Objects(i).x + m_Objects(i).vx * (tmrMain.Interval / 1000)

nextY = m_Objects(i).y + m_Objects(i).vy * (tmrMain.Interval / 1000)

' 边界碰撞检测 (2.25-13.25cm垂直范围)

If nextX < 0 Or nextX > DISPLAY_WIDTH_CM Then

m_Objects(i).vx = -m_Objects(i).vx

Else

m_Objects(i).x = nextX

End If

If nextY < 2.25 Then

m_Objects(i).vy = Abs(m_Objects(i).vy) ' 确保向下反弹

m_Objects(i).y = 2.25 + (2.25 - nextY) ' 修正位置

ElseIf nextY > 13.25 Then

m_Objects(i).vy = -Abs(m_Objects(i).vy) ' 确保向上反弹

m_Objects(i).y = 13.25 - (nextY - 13.25) ' 修正位置

Else

m_Objects(i).y = nextY

End If

' 触碰检测 (仅对黑色目标)

If m_Objects(i).isTarget Then

CheckTouch i

End If

End If

Next i

' ' 更新意外刺激位置

' If m_UnexpectedVisible Then

' m_Unexpected.x = m_Unexpected.x - 3 * (tmrMain.Interval / 1000) ' 3cm/s速度

' If m_Unexpected.x < -1 Then ' 移出屏幕

' m_UnexpectedVisible = False

' End If

' End If

' 更新意外刺激位置 (只水平移动)

If m_UnexpectedVisible Then

m_Unexpected.x = m_Unexpected.x - 3 * (tmrMain.Interval / 1000) ' 3cm/s速度水平移动

' 垂直位置保持不变（只在水平方向移动）

' 确保不会意外改变Y坐标

If m_Unexpected.x < -1 Then ' 移出屏幕

m_UnexpectedVisible = False

End If

End If

End Sub

' 检查触碰中线

Private Sub CheckTouch(objIndex As Integer)

' 检查物体是否与中线接触 (Y坐标在CENTER_Y±0.5范围内)

If Abs(m_Objects(objIndex).y - CENTER_Y) <= OBJECT_SIZE / 2 Then

m_TouchCount = m_TouchCount + 1

' Form1.Caption = m_TouchCount

End If

End Sub

'' 显示意外刺激

'Private Sub ShowUnexpected()

' m_UnexpectedVisible = True

' m_Unexpected.isVisible = True

' m_Unexpected.x = DISPLAY_WIDTH_CM + 1 ' 从右侧进入

'

' ' 设置Y位置 (根据实验条件)

' If m_CentralCondition Then

' m_Unexpected.y = CENTER_Y ' 中央位置

' Else

' m_Unexpected.y = CENTER_Y - 5.9 ' 外周位置 (中线以上5.9cm)

' End If

'End Sub

' 绘制场景

Private Sub DrawScene()

picScreen.Cls

DrawCenterLine

Dim i As Integer

' 绘制移动物体

For i = 1 To 8

If m_Objects(i).isVisible Then

DrawObject m_Objects(i)

End If

Next i

' 绘制意外刺激

If m_UnexpectedVisible Then

DrawObject m_Unexpected

' 添加位置验证信息

If IsOnCenterLine(m_Unexpected.y) Then

picScreen.CurrentX = m_Unexpected.x

picScreen.CurrentY = m_Unexpected.y + 0.5

' picScreen.Print "在水平线上!"

End If

End If

' 显示试次时间

picScreen.CurrentX = 0.5

picScreen.CurrentY = 0.5

picScreen.Print "试次: " & m_TrialNumber & "/5 时间: " & Format(TRIAL_DURATION - m_TrialTime, "0.0") & "秒"

' 显示位置条件

picScreen.CurrentX = 0.5

picScreen.CurrentY = 1#

' picScreen.Print "条件: " & m_CentralCondition & " (" & GetPositionName(m_CentralCondition) & ")"

End Sub

' 获取位置名称的辅助函数

Private Function GetPositionName(pos As PositionCondition) As String

Select Case pos

Case Central: GetPositionName = "中央"

Case UpperPeripheral: GetPositionName = "上方"

Case LowerPeripheral: GetPositionName = "下方"

End Select

End Function

' 绘制单个物体（横竖均匀版）

Private Sub DrawObject(obj As MovingObject)

Dim halfSize As Single

halfSize = OBJECT_SIZE / 2

Dim barWidth As Single

barWidth = OBJECT_SIZE * 0.3 ' 横竖部分统一宽度为0.3cm

' 设置填充颜色

picScreen.FillColor = obj.color

picScreen.FillStyle = 0 ' 实心填充

picScreen.ForeColor = obj.color

' 设置线条宽度

picScreen.DrawWidth = 2

Select Case obj.objType

Case "L"

' 均匀的L形 - 横竖部分宽度相同

' 竖线部分 (宽0.3cm，高0.7cm)

picScreen.Line (obj.x - halfSize, obj.y - halfSize)- _

(obj.x - halfSize + barWidth, obj.y - halfSize + OBJECT_SIZE * 0.7), _

obj.color, BF

' 横线部分 (宽0.7cm，高0.3cm)

picScreen.Line (obj.x - halfSize, obj.y - halfSize + OBJECT_SIZE * 0.7)- _

(obj.x - halfSize + OBJECT_SIZE * 0.7, obj.y - halfSize + OBJECT_SIZE), _

obj.color, BF

Case "T"

' 均匀的T形 - 横竖部分宽度相同

' 横线部分 (宽1.0cm，高0.3cm)

picScreen.Line (obj.x - halfSize, obj.y - halfSize)- _

(obj.x + halfSize, obj.y - halfSize + barWidth), _

obj.color, BF

' 竖线部分 (宽0.3cm，高0.7cm)

picScreen.Line (obj.x - barWidth / 2, obj.y - halfSize + barWidth)- _

(obj.x + barWidth / 2, obj.y + halfSize), _

obj.color, BF

Case "+"

' 均匀的十字形 - 横竖部分宽度相同

' 横条 (宽1.0cm，高0.3cm)

picScreen.Line (obj.x - halfSize, obj.y - barWidth / 2)- _

(obj.x + halfSize, obj.y + barWidth / 2), obj.color, BF

' 竖条 (宽0.3cm，高1.0cm)

picScreen.Line (obj.x - barWidth / 2, obj.y - halfSize)- _

(obj.x + barWidth / 2, obj.y + halfSize), obj.color, BF

End Select

' 重置线条宽度

picScreen.DrawWidth = 1

End Sub

' 初始化实验

Private Sub Form_Load()

Randomize

ShowInstructions

m_Phase = Practice

m_PracticeCorrectCount = 0 ' 初始化正确次数计数器

SetupDisplay

End Sub

' 按键处理

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeySpace And m_Phase = Learning Then

StartTrial Standard

End If

End Sub