How to Generates a random pair of unique images in VBA Powerpoint-CodePudding

If I want to create a random order to select another pair from my image. , not repeating the random pair i've previously picked, i.e. so that once i've gone through 56 random unique images i.e. 26 random pairs, the game is over, and reset to my original 57 images and start picking random pairs again. Can this be done in VBA Powerpoint?

This is the sub I am using:

Sub RandomImage()

   Dim i As Long  

   Dim posLeft As Long

   For i = 1 To 2

  Randomize

 RanNum% = Int(57 * Rnd)   1

 Path$ = ActivePresentation.Path

 FullFileName$ = Path$   "/"   CStr(RanNum%)   ".png"

 posLeft = 50   ((i - 1) * 400)

 Call ActivePresentation.Slides(1).Shapes.AddPicture(FileName:=FullFileName$, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=posLeft, Top:=100, Width:=400)

Next

End Sub

CodePudding user response：

Please, try the next function. It uses an array built from 1 to maximum necessary/existing number. It returns the RND array element and then eliminate it from the array, next time returning from the remained elements:

Please, copy the next variables on top of the module keeping the code you use (in the declarations area):

  Private arrNo 
  Private Const maxNo As Long = 57 'maximum number of existing pictures

Copy the next function code in the same module:

Function ReturnUniqueRndNo() As Long
   Dim rndNo As Long, filt As String, arr1Based, i As Long
   If Not IsArray(arrNo) Then
        ReDim arrNo(maxNo - 1)
        For i = 0 To UBound(arrNo): arrNo(i) = i   1: Next i
    End If
   If UBound(arrNo) = 0 Then
        ReturnUniqueRndNo = arrNo(0)
        ReDim arrNo(maxNo - 1)
        For i = 0 To UBound(arrNo): arrNo(i) = i   1: Next i
        MsgBox "Reset the used array..."
        Exit Function
    End If
   Randomize
   rndNo = Int((UBound(arrNo) - LBound(arrNo)   1) * Rnd   LBound(arrNo))
   ReturnUniqueRndNo = arrNo(rndNo) 'return the array element
   filt = arrNo(rndNo) & "$$$": arrNo(rndNo) = filt 'transform the array elem to be removed
   arrNo = filter(arrNo, filt, False)  'eliminate the consumed number, but returning a 0 based array...
End Function

The used array is reset when reaches its limit and send a message.

It may be tested using the next testing Sub:

Sub testReturnUniqueRndNo()
   Dim uniqueNo As Long, i As Long
   For i = 1 To 2
        uniqueNo = ReturnUniqueRndNo
        Debug.Print uniqueNo
   Next i
End Sub

In order to test it faster, you may modify maxNo at 20...

After testing it, you have to modify your code in the next way:

Sub RandomImage()
   Dim i As Long, posLeft As Long, RanNum%, path$, fullFileName$

   path = ActivePresentation.path
   For i = 1 To 2
        RanNum = ReturnUniqueRndNo
        fullFileName = path   "/"   CStr(RanNum)   ".png"

        posLeft = 50   ((i - 1) * 400)

        Call ActivePresentation.Slides(1).Shapes.AddPicture(fileName:=fullFileName, _
           LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, left:=posLeft, top:=100, width:=400)
   Next
End Sub

Please, test it and send some feedback. I did not test it in Access, but it should work...