Untitled

Sub CreateGamifiedNounPPT()
    Dim ppt As Object
    Dim slide As Object
    Dim slideIndex As Integer
    Dim quizSlide As Object
    Dim answerSlide As Object
    
    ' Create a new PowerPoint presentation
    Set ppt = CreateObject("PowerPoint.Application")
    ppt.Visible = True
    ppt.Presentations.Add
    slideIndex = 1
    
    ' Title Slide
    Set slide = ppt.ActivePresentation.Slides.Add(slideIndex, 1) ' ppLayoutTitle
    slide.Shapes.Title.TextFrame.TextRange.Text = "Noun Quiz Game"
    slide.Shapes.Placeholders(2).TextFrame.TextRange.Text = "Let's identify nouns!"
    slideIndex = slideIndex + 1
    
    ' Add quiz slides
    AddQuizSlide ppt, slideIndex, "Which one is a noun?", "Cat", "Run", "Blue", "Happy", 1
    slideIndex = slideIndex + 1
    
    AddQuizSlide ppt, slideIndex, "Which one is a noun?", "Book", "Quickly", "Under", "Bright", 1
    slideIndex = slideIndex + 1
    
    AddQuizSlide ppt, slideIndex, "Which one is a noun?", "Car", "Jump", "Beautiful", "Softly", 1
    slideIndex = slideIndex + 1
    
    MsgBox "Gamified Noun Quiz Presentation Created!"
End Sub

Sub AddQuizSlide(ppt As Object, slideIndex As Integer, question As String, _
                 answer1 As String, answer2 As String, answer3 As String, answer4 As String, correctAnswer As Integer)
    Dim slide As Object
    Dim questionShape As Object
    Dim answerShape As Object
    Dim answerButton As Object
    Dim correctShape As Object
    Dim incorrectShape As Object
    Dim i As Integer
    Dim answers(1 To 4) As String
    
    answers(1) = answer1
    answers(2) = answer2
    answers(3) = answer3
    answers(4) = answer4
    
    ' Add a new slide for the question
    Set slide = ppt.ActivePresentation.Slides.Add(slideIndex, 2) ' ppLayoutText
    slide.Shapes.Title.TextFrame.TextRange.Text = question
    
    For i = 1 To 4
        Set answerShape = slide.Shapes.AddTextbox(1, 100, 100 + (i * 50), 400, 50) ' msoTextOrientationHorizontal
        answerShape.TextFrame.TextRange.Text = answers(i)
        
        ' Add button for answer
        Set answerButton = slide.Shapes.AddShape(1, 500, 100 + (i * 50), 100, 50) ' msoShapeRectangle
        answerButton.TextFrame.TextRange.Text = "Select"
        
        ' Add action to button
        If i = correctAnswer Then
            answerButton.ActionSettings(1).Action = 1 ' ppActionRunMacro
            answerButton.ActionSettings(1).Run = "CorrectAnswer"
        Else
            answerButton.ActionSettings(1).Action = 1 ' ppActionRunMacro
            answerButton.ActionSettings(1).Run = "IncorrectAnswer"
        End If
    Next i
End Sub

Sub CorrectAnswer()
    MsgBox "Correct! Well done!"
End Sub

Sub IncorrectAnswer()
    MsgBox "Incorrect. Try again!"
End Sub