question

ShinyFlags-4193 avatar image
0 Votes"
ShinyFlags-4193 asked ·

How can I use VBA (Excel) to randomise the placement of quiz answer buttons on Powerpoint slides?

Background:

I'm trying to create a quiz using powerpoint where there are four buttons on each slide (Correct Answer, Wrong Answer, Wrong Answer, Wrong Answer). Depending which is selected, the user is redirected to a different slide. And to make things more difficult for the players, I'm wanting to randomise the location of the answer buttons e.g. randomly swap the correct answer location, with the wrong answer location etc.

UukAw.png

Presentation and Spreadsheet files on OneDrive

Target:

I'm trying to use vba through excel to first find the top and left co-ordinates for each shape, on each slide. And then loop through the presentation a second time, to randomise the placement of my answer buttons (randomly swap them around).

Clarification:

Each of my answer buttons are made up of two parts, a transparent rectangle shape (which has an action link to a particular slide depending whether or not the user selected the correct or wrong answer) as well as a text field (with a red background) which says either wrong or correct answer.

Problem:

I'm currently having problems storing the top and left co-ordinates for each shape, on each slide. So I can then loop through each slide and randomise the placement of my potential answer buttons.

So Far
I'm able to access and store the top and left locations of each shape locally, but I'm not able to store them in my nested classes. Instead when I attempt to pass through the array of shapes found on a particular slide to one of my classes, each time I attempt to access this passed through array, it shows as empty even though I know values are being passed through.


Any suggestions would be fantastic


My Code:

Module 1

 Option Explicit
    
 Sub CreateQuiz()
    
     Dim oPPApp      As Object, oPPPrsn As Object, oPPSlide As Object
     Dim oPPShape    As Object
     Dim FlName      As String
      
    
              '~~> Change this to the relevant file
     FlName = ThisWorkbook.Path & "/Quiz.pptm"
    
    
        
     '~~> Establish an PowerPoint application object
     On Error Resume Next
     Set oPPApp = GetObject(, "PowerPoint.Application")
        
     If Err.Number <> 0 Then
         Set oPPApp = CreateObject("PowerPoint.Application")
     End If
     oPPApp.Visible = False
        
        
     Set oPPPrsn = oPPApp.Presentations.Open(FlName, True)
        
  Dim currentPresentation As New Presentation
          Dim numSlides As Integer
         numSlides = 0
     For Each oPPSlide In oPPPrsn.Slides
         Dim currentSlide As New shapesOnSlide
         Dim numShapes As Integer
         numShapes = 0
         For Each oPPShape In oPPSlide.shapes
    
                      Dim currentShape As New shapeDetails
                     currentShape.slideNumber = oPPSlide.slideNumber
                     currentShape.name = oPPShape.name
                     currentShape.left = oPPShape.left
                     currentShape.top = oPPShape.top
                          
                     currentSlide.size = numShapes
                     currentSlide.aShape = currentShape
         
         numShapes = numShapes + 1
         Next
           
        currentPresentation.Slide(numSlides) = currentSlide
    
         numSlides = numSlides + 1
     Next
     currentPresentation.printAll
        
 End Sub

ShapeDetails Class

 Private ElementSlideNumber As Integer
 Private ElementName As String
 Private ElementLeft As Double
 Private ElementTop As Double
    
 Public Property Get slideNumber() As Integer
     slideNumber = ElementSlideNumber
 End Property
    
 Public Property Let slideNumber(value As Integer)
     ElementSlideNumber = value
 End Property
    
 Public Property Get name() As String
     name = ElementName
 End Property
    
 Public Property Let name(value As String)
     ElementName = value
 End Property
    
 Public Property Get left() As Double
     left = ElementLeft
 End Property
    
 Public Property Let left(value As Double)
     ElementLeft = value
 End Property
    
 Public Property Get top() As Double
     top = ElementTop
 End Property
    
 Public Property Let top(value As Double)
     ElementTop = value
 End Property
    
 Public Sub PrintVars()
     Debug.Print "Slide: " & slideNumber & " Position: " & left & "," & top & ", Slide Name: " & name
        
 End Sub

shapesonSlide Class

 Private allShapes(99999) As Variant
 Private collectionSize As Integer
    
    
    
 Public Property Get size() As Integer
     size = collectionSize
 End Property
    
 Public Property Let size(value As Integer)
     collectionSize = value
 End Property
    
    
    
 Public Property Get aShape() As Variant
     shapes = allShapes(collectionSize)
 End Property
    
 Public Property Let aShape(value As Variant)
     allShapes(collectionSize) = value
 End Property
    
    
 Public Property Get everyShape() As Variant
     everyShape = allShapes()
 End Property
    
 Public Property Let everyShape(value As Variant)
     everyShape = value
 End Property
    
    
    
 Sub compareSizes(newIndex As Integer)
 If (newIndex > collectionSize) Then
 collectionSize = newIndex
 End If
 End Sub
    
 Public Sub printSize()
 Debug.Print collectionSize
 End Sub

Presentation Class

 Private allSlides() As shapesOnSlide
    
 Private Sub Class_Initialize()
     ReDim allSlides(0)
 End Sub
    
 Public Property Get Slides() As shapesOnSlide()
     Slides = allSlides
 End Property
    
 Public Property Get Slide(index As Integer) As shapesOnSlide
     Slide = allSlides(index)
 End Property
    
 Public Property Let Slide(index As Integer, currentSlide As shapesOnSlide)
     If index > UBound(allSlides) Then ReDim Preserve allSlides(index)
     allSlides(index) = currentSlide
 End Property
    
 Public Sub printAll()
     For Each currentSlide In allSlides
     For Each currentShape In currentSlide.everyShape
        
          Debug.Print currentShape.name
     Next
     Next
 End Sub



office-vba-dev
· 1
10 |1000 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.

@ShinyFlags-4193
As your issue is more realted to VBA, but the tag "office-excel-itpro" focus more on general issues of Excel, I would remove the tag.
Thanks for your understanding.

0 Votes 0 ·

1 Answer

TvanStiphout avatar image
0 Votes"
TvanStiphout answered ·

I might do something like this pseudo-code
While not all buttons placed
get a random number between 1 and ButtonCount
if that location not already filled, fill it with the next button
wend

To get a random number, look up the Rnd function in help file, as well as Randomize.

·
10 |1000 characters needed characters left characters exceeded

Up to 10 attachments (including images) can be used with a maximum of 3.0 MiB each and 30.0 MiB total.