ppt滚动动画随机选题

shaochuan_2008

已于 2022-11-30 09:15:57 修改

阅读量4.4k

点赞数

分类专栏： vba开发 PPT 文章标签： windows vba

于 2022-05-26 00:11:22 首次发布

本文链接：https://blog.csdn.net/shaochuan_2008/article/details/124976301

版权

vba开发同时被 2 个专栏收录

6 篇文章 3 订阅

订阅专栏

PPT

1 篇文章 0 订阅

订阅专栏

一、需求概述

最近在做个培训，想搞个课堂互动，准备好题库，然后在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