Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

VBA PowerPoint Discussion :

Générer une synthèse détaillée d’un quiz (VBA)


Sujet :

VBA PowerPoint

  1. #1
    Nouveau Candidat au Club
    Générer une synthèse détaillée d’un quiz (VBA)
    Bonjour à tous,

    Je travaille actuellement sur la création d’un système d’auto-évaluation pour une entreprise dans le cadre d’une alternance. Malheureusement aucune ressource ne m’a été donné pour réaliser ce projet, j’ai donc décidé de me tourner vers un PowerPoint interactif.
    J’ai créé un document ppt qui permet à une personne de faire un test en répondant à des questions générées automatiquement depuis un document excel et d’envoyer le score par email à un responsable.

    Toutefois, il est nécessaire qu’une fois le test terminé, le responsable puisse accéder au détail des questions posées, des réponses données / attendues sur un document (Word, PDF, dans l’email, ou autres …) pour un entretien ultérieur.
    Je souhaiterai conserver mon document Excel tel qu’il est c’est-à-dire comme une interface de mise en page pour le responsable afin de limiter les risques d’intervention sur le code.
    Je suis un peu court d’options donc je me tourne vers vous : Quelles solutions me conseillez-vous pour générer une synthèse du déroulement d’un questionnaire réalisé depuis ppt avec VBA ?

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
    272
    273
    274
    275
    276
    277
    278
    279
    280
    281
    282
    283
    284
    285
    286
    287
    288
    289
    290
    291
    292
    293
    294
    295
    296
    297
    298
    299
    300
    301
    302
    303
    304
    305
    306
    307
    308
    309
    310
    311
    312
    313
    314
    315
    316
    317
    318
    319
    320
    321
    322
    323
    324
    325
    326
    327
    328
    329
    330
    331
    332
    333
    334
    335
    336
    337
    338
    339
    340
    341
    342
    343
    Public NOOFQS    As Integer
     
    Public Score_value As String
     
    'Used to manipulated the unicode values of bulleted lists
    Const UD_CODE_1 = 111
    Const UD_CODE_2 = 8226
     
    Public QNo As Integer
    Public ExitFlag As Boolean
    Public Qs() As String
    Public Choices() As String
    Public Ans() As Integer
    Public UserAns() As Integer
     
    Sub NextSlide()
    ' Store the ans for later
    'UserAns(QNo - 1) = 1
     
    With SlideShowWindows(1).Presentation.Slides(3)
    .Shapes("ans-incorrect1").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect2").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect3").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-correct").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    End With
     
    If QNo < NOOFQS Then
        QNo = QNo + 1
        SlideShowWindows(1).Presentation.Slides("Slide52").Shapes(3).TextFrame.TextRange.Text = Qs(QNo - 1)
        AssignValues
    Else
        Call StopQuiz
    End If
    DoEvents
    End Sub
     
    Sub StopQuiz(Optional EndType As Boolean = False)
    ' EndType is used as a boolean Flag to indicate whether the user ran out of time
    ' or whether it was normal exit
    Dim ScoreCard As Integer
    Dim Ctr As Integer
     
     
     
     
    ExitFlag = True
    With SlideShowWindows(1)
    For Ctr = 0 To NOOFQS - 1
        If Ans(Ctr) = UserAns(Ctr) Then ScoreCard = ScoreCard + 1
    Next Ctr
    If EndType = False Then
        .Presentation.Slides("Slide39").Shapes("Closing").TextFrame.TextRange.Text = "Your score is : " & ScoreCard & " correct out of " & NOOFQS
     
        Score_value = "Your score is : " & ScoreCard & " correct out of " & NOOFQS
    Else
        .Presentation.Slides("Slide39").Shapes("Closing").TextFrame.TextRange.Text = "Sorry!!! Either you ran out of time or you chickened out" _
                & vbCrLf & "Better luck next time." & vbCrLf _
                & "Your score is: " & ScoreCard & " correct out of " & NOOFQS
     
                Score_value = "Sorry!!! Either you ran out of time or you chickened out" _
                & vbCrLf & "Better luck next time." & vbCrLf _
                & "Your score is: " & ScoreCard & " correct out of " & NOOFQS
    End If
        .View.GotoSlide (.Presentation.Slides("Slide39").SlideIndex)
    End With
    End Sub
     
    Sub StopIt()
    Call StopQuiz(True)
    End Sub
     
     
    Sub BeginQuiz()
    Dim Ctr As Integer
    Dim RNmax As Long
     
     
    Dim oWB As Workbook
    Dim xlS As Excel.Worksheet
    Set oExcel = New Excel.Application
    Set oWB = oExcel.Workbooks.Open(ActivePresentation.Path + "\" + "Import.xlsx")
    oExcel.Visible = False
    Dim y As Integer
    Set xlS = oWB.Sheets(1)
     
     
    RNmax = xlS.Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count - 1
     
    NOOFQS = RNmax
     
    RNmax = RNmax * 4
     
    ReDim Qs(NOOFQS - 1)
    ReDim Ans(NOOFQS - 1)
    ReDim UserAns(NOOFQS - 1)
    ReDim Choices(NOOFQS - 1, 3)
     
    y = 0
     
    For i = 0 To RNmax - 1
     
    ' All the questions
    'Qs(0) = "1)What does Narcissistic mean?"
    'Qs(1) = "2)What does Confidant mean?"
    'Qs(2) = "3)Black Pearl is a nick name for?"
    'Qs(3) = "4)What is your NAme?"
     
    Qs(y) = xlS.Cells(i + 2, 1).Value
     
     
    Choices(y, 0) = xlS.Cells(i + 2, 2).Value '" Keshav"
    Choices(y, 1) = xlS.Cells(i + 3, 2).Value
    Choices(y, 2) = xlS.Cells(i + 4, 2).Value
    Choices(y, 3) = xlS.Cells(i + 5, 2).Value
     
     
    Ans(y) = xlS.Cells(i + 2, 3).Value
     
     
    i = i + 3
     
    y = y + 1
     
    Next
     
    oWB.Close SaveChanges:=True
    oExcel.Quit
     
    ' Set all user answers to negative
    For Ctr = 0 To NOOFQS - 1
    UserAns(Ctr) = -1
    Next Ctr
     
     
     
    ' Provide the answer list here.
    ' Ans(0) = 0 means that the correct answer to the 1st question is the 1st choice.
    ' Ans(1) = 1 means that the correct answer to the 2nd question is the 2nd choice.
    ' Ans(2) = 1 means that the correct answer to the 3rd question is the 2nd choice.
     
     
     
     
    QNo = 1
    AssignValues
     
    With SlideShowWindows(1)
        .View.GotoSlide (.Presentation.Slides("Slide52").SlideIndex)
    End With
    ' Comment the line below to stop the timer.
    Call Tmr
    End Sub
     
    Sub SetBulletUnicode(ShapeName As String, Code As Integer)
    With SlideShowWindows(1).Presentation.Slides("Slide40").Shapes(ShapeName).TextFrame.TextRange.ParagraphFormat.Bullet
            .UseTextFont = msoTrue
            .Character = Code
    End With
    End Sub
    Sub ButtonChoice1()
     
    With SlideShowWindows(1).Presentation.Slides(3)
    .Shapes("ans-incorrect1").Fill.ForeColor.RGB = RGB(34, 139, 34)
     
    .Shapes("ans-incorrect2").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect3").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-correct").Fill.ForeColor.RGB = RGB(255, 215, 0)
    End With
     
    UserAns(QNo - 1) = 0
     
    AssignValues
     
     
     
    End Sub
    Sub ButtonChoice2()
     
    With SlideShowWindows(1).Presentation.Slides(3)
    .Shapes("ans-incorrect2").Fill.ForeColor.RGB = RGB(34, 139, 34)
     
    .Shapes("ans-incorrect1").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect3").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-correct").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    End With
     
    UserAns(QNo - 1) = 1
    AssignValues
     
     
    End Sub
    Sub ButtonChoice3()
     
    With SlideShowWindows(1).Presentation.Slides(3)
     
    .Shapes("ans-incorrect3").Fill.ForeColor.RGB = RGB(34, 139, 34)
    .Shapes("ans-incorrect1").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect2").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-correct").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    End With
     
    UserAns(QNo - 1) = 2
    AssignValues
    End Sub
     
    Sub ButtonChoice4()
    ActivePresentation.SlideShowSettings.Run
     
    With SlideShowWindows(1).Presentation.Slides(3)
    .Shapes("ans-correct").Fill.ForeColor.RGB = RGB(34, 139, 34)  'RGB(255, 0, 0)
     
    .Shapes("ans-incorrect1").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect2").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
    .Shapes("ans-incorrect3").Fill.ForeColor.RGB = RGB(255, 215, 0)
     
     
    End With
     
    UserAns(QNo - 1) = 3
    AssignValues
    End Sub
     
     
    Sub Tmr()
     
    'Just in the eventuality that you click the start button twice
    'isRunning stores the current state of the macro
    'TRUE = Running; FALSE = Idle
    ExitFlag = False
    Static isRunning As Boolean
    If isRunning = True Then
        End
    Else
        isRunning = True
        Dim TMinus As Integer
        Dim xtime As Date
        xtime = Now
     
        With ActivePresentation.Slides(3).Shapes("Timer")
     
        'Countdown in seconds
        TMinus = 59
     
        Do While (TMinus > -1)
        DoEvents
            ' Rather crude way to determine if a second has elapsed
            If ExitFlag = True Then
                .TextFrame.TextRange.Text = "00:00:00"
                isRunning = False
                Exit Sub
            End If
            If Format(Now, "ss") <> Format(xtime, "ss") Then
                xtime = Now
     
               .TextFrame.TextRange.Text = Format(TimeValue(Format(Now, "hh:mm:ss")) - _
                                   TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), "hh:mm:ss")
                TMinus = TMinus - 1
                ' Let the display refresh itself
            End If
        Loop
        End With
        Debug.Print "came here"
        isRunning = False
        StopQuiz True
        End
    End If
    End Sub
    Sub AssignValues()
     Dim sh As Shape
     
     
    ActivePresentation.SlideShowSettings.Run
     
        With SlideShowWindows(1).Presentation.Slides(3)
            .Shapes(1).TextFrame.TextRange.Text = "Question" & " " & QNo
            .Shapes(3).TextFrame.TextRange.Text = Qs(QNo - 1)
     
            .Shapes("ans-incorrect1").TextFrame.TextRange.Text = Choices(QNo - 1, 0)
            .Shapes("ans-incorrect2").TextFrame.TextRange.Text = Choices(QNo - 1, 1)
            .Shapes("ans-incorrect3").TextFrame.TextRange.Text = Choices(QNo - 1, 2)
            .Shapes("ans-correct").TextFrame.TextRange.Text = Choices(QNo - 1, 3)
        End With
    End Sub
    Sub ShowAnswers()
    Dim AnsList As String
    AnsList = "The answers are as follows:" & vbCrLf
    For X = 0 To NOOFQS - 1
        AnsList = AnsList & Qs(X) & vbTab & " Answer:" & Choices(X, Ans(X)) & vbCrLf
    Next X
    MsgBox AnsList, vbOKOnly, "Correct answers"
    End Sub
     
     
     
    Sub SendMAil()
     
     Dim oApp As Object
        Dim oMail As Object
     
        ActivePresentation.SlideShowWindow.View.Exit
     
        Err.Clear
        On Error Resume Next
     
        Set oApp = GetObject(Class:="Outlook.Application")
        If Err <> 0 Then Set oApp = CreateObject("Outlook.Application")
        Err.Clear
        Set oMail = oApp.CreateItem(0)
        With oMail
            .Subject = "Add Subject Here"
            .To = "Add Recipient here"
            'copy to self
            .CC = "Add CC if any"
            .BodyFormat = 1
            .Body = Score_value
            .Display
        End With
     
     
     
        'cleanup
        Set oMail = Nothing
        Set oApp = Nothing
     
        'All OK?
        If Err = 0 Then SendEMail = True Else SendEMail = False
     
     
    End Sub


    Pour info :
    Je débute sur le langage VBA donc j’espère vous avoir donné toutes les infos utiles
    Je me suis déjà tournée vers le support IT de l’entreprise sans succès.
    Je travaille depuis un ordinateur qui gère la version 16.0 de Microsoft (Références VBA) mais en entreprise la version est la 15.0.
    Je n’attends pas à ce que le travail soit fait par un autre mais j’espère bénéficier de vos idées et conseils.

    Je vous remercie de prendre le temps de me lire.
    Bonne soirée!

  2. #2
    Nouveau membre du Club
    Bonsoir

    J'imagine que ton ppt va comprendre des slides avec des zones de texte ou une autre forme tant pour les questions que pour les réponses mais qu'il faudra nommer afin de pouvoir retrouver les réponses.

    J'imagine qu'à la fin du quizz, tu pourras relire tous ces zones de texte afin d'en tirer une conclusion.

    Le moins facile mais c'est tout à fait possible c'est l'échange Excel-Ppt mais tu trouveras facilement via les forums comment communiquer.

    Je ne sais pas si le choix de ppt pour un quizz est l'idéal mais pourquoi pas.

    Je n'en ai jamais fait mais globalement, avec un minimum de connaissance en vba-ppt, cela ne me parait pas très compliqué : tu coinces où ?

  3. #3
    Nouveau Candidat au Club
    Citation Envoyé par Hifu Man Voir le message
    Bonsoir

    J'imagine que ton ppt va comprendre des slides avec des zones de texte ou une autre forme tant pour les questions que pour les réponses mais qu'il faudra nommer afin de pouvoir retrouver les réponses.

    J'imagine qu'à la fin du quizz, tu pourras relire tous ces zones de texte afin d'en tirer une conclusion.

    Le moins facile mais c'est tout à fait possible c'est l'échange Excel-Ppt mais tu trouveras facilement via les forums comment communiquer.

    Je ne sais pas si le choix de ppt pour un quizz est l'idéal mais pourquoi pas.

    Je n'en ai jamais fait mais globalement, avec un minimum de connaissance en vba-ppt, cela ne me parait pas très compliqué : tu coinces où ?
    Bonsoir

    Merci à toi d'avoir lu ma problématique
    Je suis d'accord avec toi, ppt pour un quiz n'est pas l'idéal mais je n'ai pas eu beaucoup de choix pour mon projet...

    En fait tout ce que j'ai expliqué pour mon quiz fonctionne déjà (zones de texte, échange Excel-PPT, score, envoi par email, etc.). Le code que je partage vient de mes fichiers PPT et Excel qui fonctionnent réellement. Je n'ai pas partagé mes fichiers publiquement parce que j'ai fait un travail sur le design spécifiquement pour l'entreprise pour laquelle je bosse.

    Ma problématique c'est que pour l'instant je n'obtient que le score total : ex "Votre score est de 5 bonnes réponses sur 7" et que je voudrai un résumé plus détaillé à faire parvenir à qqn par outlook.

    Mon PPT se contente simplement d'afficher un contenu écrit depuis mon Excel et d'identifier les cases où se trouvent les bonnes/mauvaises réponses mais je ne sais pas comment faire pour générer une synthèse du quizz à la fin (rappel des questions posées, des réponses attendues et des réponses choisies)

    L'idée est que le ppt ne soit qu'une interface pour faire le quiz et que l'on puisse consulter une fiche récapitulative pour archiver l'évaluation