Hi,
I am making a workbook for students and I want to be able to shuffle objects (shapes, textboxes, anything) randomly but in a way that they only swap places between each other if they have the same name (one group - TextBox 1, TextBox 2, TextBox 3, TextBox 4...., second group Photo 1, Photo 2, Photo 3, third group - Shape 1 Shape 2....)
On one slide I have 4 text boxes on specific locations and 4 photos and 4 shapes, I want them to shuffle around but so that photo 1 goes to either place of photo 2 3 or 4, textbox 1 to go to either place of tb 234 and vice versa.
All shapes and objects have the same size.
This VBA code shuffles everything on the slides (not what I want).
Can anyone help?
Thank you.
Dim oSlide As Slide, oShape As Shape, iShapesCount As Integer
For kp = 1 To ActivePresentation.Slides.Count
Set oSlide = ActivePresentation.Slides(kp)
iShapesCount = oSlide.Shapes.Count
Dim sMsg As String
If iShapesCount < 2 Then
sMsg = "To run the program, more than one shape are needed in the current slide!"
MsgBox sMsg, vbInformation, "Procedure Canceled"
Exit Sub
End If
Dim oShapesNum()
ReDim oShapesNum(iShapesCount)
Dim i As Integer
Dim iLeft As Double, iTop As Double, iHeight As Double, iWidth As Double
Dim oShapesArr() As Double
ReDim oShapesArr(iShapesCount, 3)
For i = 1 To iShapesCount
oShapesNum(i) = i
With oSlide.Shapes(i)
oShapesArr(i, 0) = .Left
oShapesArr(i, 1) = .Top
oShapesArr(i, 2) = .Height
oShapesArr(i, 3) = .Width
End With
Next i
Dim oShuffledArr As Variant
oShuffledArr = SuffleNoReplace(oShapesNum)
Dim iNum As Integer
For i = 1 To iShapesCount
iNum = oShuffledArr(i)
With oSlide.Shapes(i)
iLeft = oShapesArr(iNum, 0)
iTop = oShapesArr(iNum, 1)
iHeight = oShapesArr(iNum, 2)
iWidth = oShapesArr(iNum, 3)
.Left = iLeft
.Top = iTop
.Height = iHeight
.Width = iWidth
End With
Next i
Next
End Sub
Function ShuffleNoReplace
Dim iDim As Integer
iDim = UBound(oArr)
Randomize Timer
'Dim i As Integer, aVal As Integer, ok As Boolean, bVal As Integer, tmp As Integer
Dim i, aVal, ok As Boolean, bVal, tmp
If iDim = 2 Then
oArr(1) = 2
oArr(2) = 1
GoTo endFunc
End If
For i = 1 To iDim
aVal = i 'sujet A
ok = False
While ok = False
bVal = aVal
While bVal = aVal
bVal = Int(iDim * Rnd) + 1
Wend
If oArr(bVal) <> aVal And oArr(aVal) <> bVal Then
tmp = oArr(aVal): oArr(aVal) = oArr(bVal): oArr(bVal) = tmp
ok = True
End If
Wend
Next
endFunc:
SuffleNoReplace = oArr
' For i = 1 To iDim
' Debug.Print oArr(i)
' Next
End Function
I am making a workbook for students and I want to be able to shuffle objects (shapes, textboxes, anything) randomly but in a way that they only swap places between each other if they have the same name (one group - TextBox 1, TextBox 2, TextBox 3, TextBox 4...., second group Photo 1, Photo 2, Photo 3, third group - Shape 1 Shape 2....)
On one slide I have 4 text boxes on specific locations and 4 photos and 4 shapes, I want them to shuffle around but so that photo 1 goes to either place of photo 2 3 or 4, textbox 1 to go to either place of tb 234 and vice versa.
All shapes and objects have the same size.
This VBA code shuffles everything on the slides (not what I want).
Can anyone help?
Thank you.
Sub ShuffleShapesAll()
Dim oSlide As Slide, oShape As Shape, iShapesCount As Integer
For kp = 1 To ActivePresentation.Slides.Count
Set oSlide = ActivePresentation.Slides(kp)
iShapesCount = oSlide.Shapes.Count
Dim sMsg As String
If iShapesCount < 2 Then
sMsg = "To run the program, more than one shape are needed in the current slide!"
MsgBox sMsg, vbInformation, "Procedure Canceled"
Exit Sub
End If
Dim oShapesNum()
ReDim oShapesNum(iShapesCount)
Dim i As Integer
Dim iLeft As Double, iTop As Double, iHeight As Double, iWidth As Double
Dim oShapesArr() As Double
ReDim oShapesArr(iShapesCount, 3)
For i = 1 To iShapesCount
oShapesNum(i) = i
With oSlide.Shapes(i)
oShapesArr(i, 0) = .Left
oShapesArr(i, 1) = .Top
oShapesArr(i, 2) = .Height
oShapesArr(i, 3) = .Width
End With
Next i
Dim oShuffledArr As Variant
oShuffledArr = SuffleNoReplace(oShapesNum)
Dim iNum As Integer
For i = 1 To iShapesCount
iNum = oShuffledArr(i)
With oSlide.Shapes(i)
iLeft = oShapesArr(iNum, 0)
iTop = oShapesArr(iNum, 1)
iHeight = oShapesArr(iNum, 2)
iWidth = oShapesArr(iNum, 3)
.Left = iLeft
.Top = iTop
.Height = iHeight
.Width = iWidth
End With
Next i
Next
End Sub
Function ShuffleNoReplace
Dim iDim As Integer
iDim = UBound(oArr)
Randomize Timer
'Dim i As Integer, aVal As Integer, ok As Boolean, bVal As Integer, tmp As Integer
Dim i, aVal, ok As Boolean, bVal, tmp
If iDim = 2 Then
oArr(1) = 2
oArr(2) = 1
GoTo endFunc
End If
For i = 1 To iDim
aVal = i 'sujet A
ok = False
While ok = False
bVal = aVal
While bVal = aVal
bVal = Int(iDim * Rnd) + 1
Wend
If oArr(bVal) <> aVal And oArr(aVal) <> bVal Then
tmp = oArr(aVal): oArr(aVal) = oArr(bVal): oArr(bVal) = tmp
ok = True
End If
Wend
Next
endFunc:
SuffleNoReplace = oArr
' For i = 1 To iDim
' Debug.Print oArr(i)
' Next
End Function