一、需求概述
最近在做个培训,想搞个课堂互动,准备好题库,然后在PPT实现模拟“滚动数字”随机选择题,并自动跳转到指定数字的题目页,页面显示答题倒计时,手动跳转到答案页。再次选择题目时,在剩余未选的题目中重新随机选题。最终效果如下:
二、实现思路
寒暄下,以前一直在word/excel进行vba开发,没有涉及ppt,百度搜索后发现原来ppt也可以vba开发,感觉新鲜的很O(∩_∩)O
1、将题目和答案分别按顺序都做成ppt幻灯片,然后通过“题目开始页码+随机数字=题目页码,答案开始页码+题目号=答案页码”来定位页面。
2、通过for循环语句+随机数来模拟滚动随机的数字效果。
Do While i < 50 '用来生成模拟数字滚动的动画
n = Int((x * Rnd) + 1) '用来生成总题目数随机数
Randomize
n = Int((x * Rnd) + 1) '用来再次生成总题目数随机数
TextBox5.Value = n
i = i + 1
Savetime = timeGetTime
While timeGetTime < Savetime + 35
DoEvents
Wend
Loop
3、由于ppt不太方便存储数据,也不容易操作。因此想到通过一个excel文件来保存题目的题目数及选中状态,这样可以实现每次随机选的题目都是剩余没有答过的。而且每次开始前,可以重新更新题目状态(如YES是选中过的,NO是未选)。如
4、在题目页实现倒计时功能,可以手动开始和结束。经查可以通过 "winmm.dll"的timeGetTime函数来实现倒计时。效果如下:
三、代码实现
1、开始随机选题的代码
Private Sub button1_Click()
Dim m As Integer '用来生成随机题数
Dim n As Integer '用来生成随机题数,模拟数字滚动效果
Dim r As Integer '行数
Dim s As Integer '判断是否已答的行数
Dim p As Integer 'PPT中题目开始的页码
Dim x As Integer '设置总题目数
Dim y As Integer '未答的总数,用来生产随机数
Dim v As String '存储题目回答状态
Dim Savetime As Double
Dim MyexcelApp As New Excel.Application
Dim MyexcelBook As New Excel.Workbook
Dim MyexcelSheet As New Excel.Worksheet
sheetname = Label2.Caption 'sheet标签页名称
Pathstr = Application.ActivePresentation.Path + "\timu.xlsx" '获取文件路径,与当前文件同目录
Set MyexcelBook = MyexcelApp.Workbooks.Open(Pathstr)
Set MyexcelSheet = MyexcelBook.Worksheets(sheetname)
MyexcelSheet.Activate
x = MyexcelSheet.Range("B1").Value '读取EXCEL文件总题数
y = MyexcelSheet.Range("B2").Value '读取EXCEL文件未答的总题数
p = MyexcelSheet.Range("B3").Value '读取EXCEL文件PPT题目开始页码
i = 1
Do While i < 50 '用来生成模拟数字滚动的动画
' If j = 48 Then
' TextBox1.Value = "结束"
' Exit Do
' Else
n = Int((x * Rnd) + 1) '用来生成总题目数随机数
Randomize
n = Int((x * Rnd) + 1) '用来再次生成总题目数随机数
TextBox5.Value = n
' End If
i = i + 1
Savetime = timeGetTime
While timeGetTime < Savetime + 35
DoEvents
Wend
Loop
If y > 0 Then
m = Int((y * Rnd) + 1) '用来生成未答题数的随机数据
Randomize
m = Int((y * Rnd) + 1) '用来再次生成未答题数的随机数据
j = 5 'excel中题号开始的行号
r = 0
s = 0
Do While j <= x + 4
v = MyexcelSheet.Range("B" & j).Value
If v = "NO" Then
s = s + 1
End If
If s = m Then
r = MyexcelSheet.Range("A" & j).Value
MyexcelSheet.Range("B" & j).Value = "YES"
TextBox5.Value = r
Exit Do
End If
j = j + 1
Loop
g = r + p - 1
MyexcelBook.Save
MyexcelBook.Close
Set MyexcelApp = Nothing
Set MyexcelBook = Nothing
Set MyexceSheet = Nothing
While timeGetTime < Savetime + 2500
DoEvents
Wend
With SlideShowWindows(1).View
.GotoSlide g
End With
Else
TextBox5.Value = "无"
End If
End Sub
2、实现倒计时
Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long '64位系统,需要增加PtrSafe标识
Public Ctr As Boolean
Const n As Integer = 180 '定义倒计时总秒数
Private Sub CommandButton1_Click()
If Ctr = True Then
Ctr = False
CommandButton1.Caption = "停止"
CommandButton1.ForeColor = RGB(255, 0, 0)
For i = 0 To n '用来生成倒计时
If Ctr = True Then
Label1.Caption = "结束"
Label1.ForeColor = RGB(255, 0, 0)
Exit For
Else
If i = n Then
Label1.Caption = "结束"
Label1.ForeColor = RGB(255, 0, 0)
Exit For
Else
Label1.Caption = n - i & "S"
Label1.ForeColor = RGB(255, 255, 255)
Savetime = timeGetTime
While timeGetTime < Savetime + 1000
DoEvents
Wend
End If
End If
Next
Else
Label1.Caption = "结束"
Label1.ForeColor = RGB(255, 0, 0)
CommandButton1.Caption = "开始"
CommandButton1.ForeColor = RGB(255, 255, 255)
Ctr = True
End If
End Sub
3、读取excel文件的题目数和题目状态
Private Sub readdata()
Dim MyexcelApp As New Excel.Application
Dim MyexcelBook As New Excel.Workbook
Dim MyexcelSheet As New Excel.Worksheet
' Pathstr = "C:\Users\lenovo\Desktop\text1.xlsx"
sheetname = Label2.Caption 'sheet标签页名称
Pathstr = Application.ActivePresentation.Path + "\timu.xlsx" '获取文件路径,与当前文件同目录
Set MyexcelBook = MyexcelApp.Workbooks.Open(Pathstr)
Set MyexcelSheet = MyexcelBook.Worksheets(sheetname)
MyexcelSheet.Activate
x = MyexcelSheet.Range("B1").Value '读取EXCEL文件总题数
y = MyexcelSheet.Range("B2").Value '读取EXCEL文件未答的总题数
Label3.Caption = x
Label1.Caption = y
MyexcelBook.Close
Set MyexcelApp = Nothing
Set MyexcelBook = Nothing
Set MyexceSheet = Nothing
End Sub
四、总结
其实ppt的vba开发跟excel/word没啥区别,本人也是第一次尝试,日常工作中还是用的比较少。以下是我实际用的ppt文件,保存题目状态的excel文件是默认与ppt同目录一起(自己可以手动修改文件位置),列改成NO则表示没有选中的。