Pasted Shape not seen as "Latest" Shape - vba

I'm in the process of automating the production of a PowerPoint report from and Excel spreadsheet. I've got the process working up until I paste a table.
I'm pasting the table to PowerPoint using PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting") and the table appears as a shape on my slide (the third shape).
To refer to the new shape I was using Set pShape = Slide2.Shapes(Slide2.Shapes.Count) but now now when I paste, the pShape is assigned "Shape 2" (not "Shape 3"). Is there something that needs to be done between the pasting and the assignment of the object?
Code below, commented where the issue occurs. (Full code removed; viewable here)
'Copy tables from Excel
Set rng = ws.Range("A:A")
rng.ColumnWidth = 22.75
Set rng = ws.Range("A4:C27")
'Copy the table range
Application.CutCopyMode = False
rng.Copy
Application.Wait (Now + TimeValue("0:00:02"))
'The issue occurs here!!! '-------------------------------------
'Paste the table in to the slide
Slide2.Select
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Name the new shape object
Set pShape = Slide2.Shapes(Slide2.Shapes.Count)
pShape.Name = "Slide_2_Table_1"
pShape.LockAspectRatio = False

'Shapes.Count' ≠ Shape Index# !
The .Count is not the same as the upper limit of current shape .Index numbers.
The numbering system is easier understood by listing all the shapes within the document:
Sub ListShapes()
'hit CTRL+G to view output in Immediate Window
Dim sh As Shape, sld As Slide, idx As Long
Set sld = ActivePresentation.Slides(1) '<-- change to your slide number
For Each sh In sld.Shapes
idx = idx + 1
Debug.Print "Shape ID#" & sh.Id, "Index #" & idx, "Name: " & sh.Name
Next sh
Debug.Print "Count of shapes: " & sld.Shapes.Count
End Sub
NOTE: There is alternative code for Excel at the bottom of this post!
To demonstrate, we can add shapes to a new document:
First, add one rectangle manually by clicking Insert (on the ribbon)
[If using Excel, click Illustrations], then Shapes, and the rectangle symbol.
Draw the shape, then hit Ctrl+C to copy it, and hit Ctrl+C four times to paste 4 copies.
Run the above procedure, and the output will be:
Shape ID#2 Index #1 Name: Rectangle 1
Shape ID#3 Index #2 Name: Rectangle 2
Shape ID#4 Index #3 Name: Rectangle 3
Shape ID#5 Index #4 Name: Rectangle 4
Shape ID#6 Index #5 Name: Rectangle 5
Count of shapes: 5         
Note that the Index is not a property of this object, but it counted in order that Excel's storing the shapes in memory (same as the order returned by the For Each..Next statement.
You can prove this by running:
Debug.Print ActivePresentation.Slides(1).Shapes(5).Name
...which in this case return Rectangle 5.
Another way to understand how Excel is storing the shapes is with the Watch Window. Add a breakline or Stop in the middle of the loop, then highlight ws.Shapes, right-click it, choose Add Watch... and click OK. Browse through the tree to discover the varies properties/attributes of the shapes within the document.
Next, if we delete the "middle rectangle" and run the above procedure again, we will get:
Shape ID#2 Index #1 Name: Rectangle 1
Shape ID#3 Index #2 Name: Rectangle 2
Shape ID#5 Index #3 Name: Rectangle 4
Shape ID#6 Index #4 Name: Rectangle 5
Count of shapes: 4         
The ID and Name of remaining shapes do not change, but the Index is renumbered to reflect the new "order".
...thus to return the name Rectangle 5 we now need to use:
Debug.Print ActivePresentation.Slides(1).Shapes(4).Name
Referring to shapes (including controls)
When you refer to a shape by number, like .Shapes(𝔁), you're referring to the shape Index Number 𝔁, not the ID number. Index numbers are dynamically assigned as needed as therefore are not a stable method to refer to a shape.
Therefore, .Count is irrelevant to the shape Index number.
Ideally, you should refer to the shape by the .Name or .ID number. If generating shapes dynamically, you'd ideally store a list of shapes in an array or collection, so you can look at the list as required.
Retrieve "Last Shape Created"
If the only reason for using the Index Number is to retrieve the "last shape created", then you could use a function like this to get the index number:
Function idxLastShape(slideNum As Long) As Long
Dim sh As Shape
For Each sh In ActivePresentation.Slides(slideNum).Shapes
idxLastShape = idxLastShape + 1
Next sh
End Function
Example Usage:
Debug.Print idxLastShape(1) 'Returns index of last shape on slide#1
NOTE: There is alternate code for Excel at the bottom of this post!
Alternatively, you could have the function return a reference to the actual shape object, rather than the number, like this:
Function LastShape(slideNum As Long) As Shape
Dim sh As Shape
For Each sh In ActivePresentation.Slides(slideNum).Shapes
Set LastShape = sh
Next sh
End Function
...so you could get the name of the "last shape" with:
Debug.Print LastShape(1).Name
Delete the most recently created shape
Using the function above, you can use any methods you would normally use with shapes. For example, you can delete the "last shape" that was created on Slide #1:
LastShape(1).Delete
CAUTION!
The examples in the post (including the deletion example!) are indiscriminate of what type of shape they're returning/editing/deleting!
There are dozens of types of shapes, from graphics to sound/video and controls. You can filter the shapes being enumerated by these procedures using the .Type property of the Shape object, as well as other methods. There is a partial list here, and more information in the links below.
Alternative code for Excel:
List all shapes on worksheet (Excel)
Sub ListShapes()
'hit CTRL+G to view output in Immediate Window
Dim sh As Shape, ws As Worksheet, idx As Long
Set ws = Sheets("Sheet1") '<-- change to your worksheet name
For Each sh In ws.Shapes
idx = idx + 1
Debug.Print "Shape ID#" & sh.ID, "Index #" & idx, "Name: " & sh.Name
Next sh
Debug.Print "Count of shapes: " & Sheets("Sheet1").Shapes.Count
End Sub
Return index number of "last shape" (Excel)
Function idxLastShape(shtName As String) As Long
Dim sh As Shape
For Each sh In Sheets(shtName).Shapes
idxLastShape = idxLastShape + 1
Next sh
End Function
Example Usage: Debug.Print idxLastShape("Sheet1")
Return reference to "last shape" object (Excel)
Function LastShape(shtName As String) As Shape
Dim sh As Shape
For Each sh In Sheets(shtName).Shapes
Set LastShape = sh
Next sh
End Function
Example Usage: Debug.Print LastShape("Sheet1").Name
More Information:
MSDN : Shapes Object (PowerPoint/VBA)
MSDN : Shapes Object (Excel/VBA)
MSDN : MsoShapeType Enumeration (Office)
Stack Overflow : Overview of working with Form Controls and ActiveX Controls
MSDN : Working with Shapes (Drawing Objects)
Office.com : How to add Shapes
BreezeTree : Programming Shapes (AutoShapes) with VBA
WiseOwl : Working with Shapes (Tutorial)
Other ways to copy from Excel to Powerpoint:
SpreadsheetGuru : Copy & Paste An Excel Range Into PowerPoint With VBA
ExcelOffTheGrid : Controlling Powerpoint from Excel using VBA
mvps.org : Paste Excel chart as pictures in PowerPoint (Paste Special)

Related

PowerPoint vba group shapes using Shape objects, not shape names

I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub

vba Looping through Shape Listbox (change type)

So I have this spreadsheet with several listboxes. In these listboxes I have some values/items that are actually filters. I want to get each item/filter of each listboxes to amend an SQL query in my code.
So I've been asked to looped through the listboxes and I managed to do it by looping the Shapes of the spreadsheet but eventually ... those listboxes are now viewed as Shapes in VBA and not listboxes anymore. I'm looking for a way to either turn my shape in listbox or maybe find a method from the Shapes type to loop each listbox's items. Here is the part of my code, so far I loop through each shapes/listboxes, if within my shapes'name there is the word "CFRA" then I want to loop within each item selected of my listbox so that my function return them.
Private Function getListFilters() As String
My_Sheet.Activate
Dim Shp
For Each Shp In My_Sheet.Shapes
pos = InStrRev(Shp.Name, "CFRA", , vbTextCompare)
MsgBox (pos)
If pos <> 0 Then
MsgBox (TypeName(Shp))
End If
Next
End Function
Thanks in advance for those who are willing to help me and have a great day :)
Since you do not explain what is to be extracted from the list box, try the next Function, please. It will deliver the list box object having "CFRA" string in its name. Of course, any string can be used:
Private Function getListObjX(strPartName As String, sh As Worksheet) As MSForms.ListBox
Dim oObj As OLEObject
For Each oObj In sh.OLEObjects
If oObj.Name Like "*" & strPartName & "*" Then
'Debug.Print oObj.Name, TypeName(oObj.Object): Stop
If TypeName(oObj.Object) = "ListBox" Then
Set getListObjX = oObj.Object: Exit Function
End If
End If
Next
End Function
It can be called in the next way:
Sub testGetListObj()
Dim sh As Worksheet, lstB As MSForms.ListBox, lstBF As ListBox
Dim i As Long, arrSel As Variant, k As Long
Set sh = ActiveSheet
Set lstB = getListObjX("CFRA", sh)
If lstB Is Nothing Then MsgBox "No such an ActiveX list box...": Exit Sub
ReDim arrSel(lstB.ListCount - 1)
For i = 0 To lstB.ListCount - 1
If lstB.Selected(i) Then
'Debug.Print lstB.List(i)
arrSel(k) = lstB.List(i): k = k + 1
End If
Next i
ReDim Preserve arrSel(k - 1)
MsgBox Join(arrSel, "|")
End Sub
But, being an ActiveX list box type, you can simply use one of its events. Of course, if you do not need to take items from more then a list box...
I also prepared a function to return the object for a Form list box (before you clarify the issue). Maybe, somebody else will use it...
Dim oObj As ListBox
For Each oObj In sh.ListBoxes 'even not being shown by intellisense, this collection exists...
If oObj.Name Like "*" & strPartName & "*" Then
'Debug.Print oObj.Name
Set getListObjF = oObj: Exit Function
End If
Next
End Function
It can be called similarly, but the lstB should be declared As ListBox.
Edited, to make the function working in one step:
Private Function getListFilters(strPartName) As String
Dim sh As Worksheet, lstB As MSForms.ListBox
Dim oObj As OLEObject, i As Long, arrSel As Variant, k As Long
Set sh = ActiveSheet ' use here your sheet
For Each oObj In sh.OLEObjects
If oObj.Name Like "*" & strPartName & "*" Then
If TypeName(oObj.Object) = "ListBox" Then
Set lstB = oObj.Object: Exit For
End If
End If
Next
If lstB Is Nothing Then MsgBox "No such an ActiveX list box...": Exit Function
ReDim arrSel(lstB.ListCount - 1)
For i = 0 To lstB.ListCount - 1
If lstB.Selected(i) Then
arrSel(k) = lstB.List(i): k = k + 1
End If
Next i
ReDim Preserve arrSel(k - 1)
getListFilters = Join(arrSel, "|")
End Function
And the function will be simple called as:
Debug.Print getListFilters("CFRA")
You access ActiveX-Objects via the OLEObjects-Collection of a worksheet. The interesting control information are in the property Object of such an object:
Use VBA function TypeName to figure out what kind of OLE object you have
Number of items can be fetched with the Object.ListCount property.
To access the items of a listbox, loop over the Object.list property (index starts at 0, so loop must run from 0 to ListCount-1)
To check if an item is selected, use the matching .Object.Selected property.
The following code will loop will print all selected items of all listboxes of a worksheet:
Sub listBoxes()
Dim objx As OLEObject
For Each objx In ActiveSheet.OLEObjects
Debug.Print "Name = " & objx.Name & " Typ = " & TypeName(objx.Object)
If TypeName(objx.Object) = "ListBox" Then
Dim i As Long
For i = 0 To objx.Object.ListCount - 1
If objx.Object.Selected(i) Then
Debug.Print objx.Name, objx.Object.list(i)
End If
Next i
End If
Next
End Sub
Update: To show the coherence between Shapes, OleObjects and ActiceX controls on a sheet:
A Shape is a container for everything that is not part of a cell/range. Could be any kind of painted shape forms (rectangels, arrows, stars...), could be an image, a chart, an OLEObject, a form control and so on.
An OLEObject is a something that is not from Excel but is put into an Excel sheet, using a technique called OLE, Object Linking and Embedding.
An ActiveX is a control (editbox, listbox...). These controls where developed by Microsoft and where meant to run in different environments (eg a browser). They are accessible via dll and this dll is added into Excel and other office programs.
Every ActiveX-Control is added as an OLEObject into a sheet, but you can have also different OLEObjects (eg an embedded Word document) that are not an ActiceX objects.
When you want to access those things via VBA, you can use the Shapes-collection that lists all shapes of a sheet (including all OLEObjects), or you can use the OLEObjects-collection that lists all OLEObjects (including all ActiveX controls). However, there is no ActiveX collection, so if you want to fetch all ActiceX-Controls, you have to loop over either the two collections mentioned above.
If you want to access an OLEObject from the shape collection, you first need to check the type of the shape, it must have the type msoOLEControlObject (12) or msoEmbeddedOLEObject (7). A list of all shape types can be found here.
If the shape is either 7 or 12, you can access the OLEObject using Shape.OLEFormat.Object. The following to loops results in exactly the same (ws is just a worksheet variable)
Dim sh As Shape, oleObj As OLEObject
For Each sh In ws.Shapes
If sh.Type = msoOLEControlObject Or sh.Type = msoEmbeddedOLEObject Then
Set oleObj = sh.OLEFormat.Object
Debug.Print oleObj.Name, oleObj.OLEType
End If
Next
For Each oleObj In ws.OLEObjects
Debug.Print oleObj.Name, oleObj.OLEType
Next
Note that sh.Name and sh.OLEFormat.Object.Name are not necessarily the same.
Now the last step is to find the ActiveX-Controls of a specific type, this was already shown in the code of the original answer above - the ActiveX-control can be accessed via oleObj.object. Check the object type if the VBA function TypeName to filter out for example your listboxes.

Cut and paste Visio shape in macro

I'm trying to write a VBA macro that builds a basic diagram from data and certain template shapes (held on a separate page). While I can cut and paste successfully, I seem to be unable to reference the new shape after I do this. I can relocate the shape before I cut and paste it, but if I try to do anything after the fact, I hit a run-time error. There are various reasons why I might need to move / update the objects later, so I need to be able to subsequently reference them.
My code is as follows:
Dim Shape as Visio.Shape
Dim ShapeID as Integer
 
‘copy shape from template page 2, ID 12
Set Shape = Application.ActiveDocument.Pages.ItemU("Page-2").Shapes.ItemFromID(12).Duplicate
 
ShapeID = Shape.ID
MsgBox ("Created shape ID: " & ShapeID)
      
'Now relocate the shape appropriately
currentX = startX + (Count * xSpacing)
currentY = startY
       
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaForceU = "" & currentX & " mm"
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaForceU = "" & currentY & " mm"
 
Shape.Cut
   
 'Now go to page 1 and paste the object
 
Application.ActiveDocument.Pages.ItemU("Page-1").Paste
‘*** THE FOLLOWING LINE THAT DOESN’T WORK ***
Set Shape = Application.ActiveDocument.Pages.ItemU("Page-1").Shapes.ItemFromID(ShapeID)
 
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaForceU = "" & currentX & " mm"
Shape.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaForceU = "" & currentY & " mm"
If I run the above, I get the error "Invalid sheet identifier" at the highlighted line (the shape is pasted successfully). If I cut this line out, I get "an exception occurred" on the following line, so it looks like I've lost my reference to the object.
A shape's ID is only unique to its page, so the new shape that you paste into Page-1 will receive a new ID and hence the error that you're receiving. Although the Duplicate method returns a shape reference to the new shape, Paste does not so you need to get a reference to it by other means - either assuming something about the window selection (as per Surrogate's answer) or by index:
Dim shp As Visio.Shape
Dim pag As Visio.Page
Set pag = ActivePage 'or some alternative reference to Page-1
Set shp = pag.Shapes.ItemU(pag.Shapes.Count)
Debug.Print shp.Index
A more usual workflow would be to generate masters (in a stencil document) and then drop those masters rather than copying and pasting between pages, but your scenario may require a different approach.
I'll add this link as useful reference for dealing with Index and ID properties:
Working with Shape Objects
[Update]
#Jon Fournier's comment below is quite right that the above does make assumptions. For example, if the DisplayLevel cell in the source shape is less than the top most shape then it will be pasted into the page's shapes collection at the corresponding index and so count won't return the correct shape ID.
An alternative approach might be to listen to the ShapeAdded event on Pages (or Page). The following is a slight adaption from the IsInScope example in the docs, with code placed ThisDocument. This allows you to top and tail your code in an event scope ID pair that you can inspect when handling the ShapeAdded event:
Private WithEvents vPags As Visio.Pages
Private pastedScopeID As Long
Public Sub TestCopyAndPaste()
Dim vDoc As Visio.Document
Set vDoc = Me 'assumes code is in ThisDocument class module, but change as required
Dim srcPag As Visio.Page
Set srcPag = vDoc.Pages.ItemU("Page-2")
Dim targetPag As Visio.Page
Set targetPag = vDoc.Pages.ItemU("Page-1")
Dim srcShp As Visio.Shape
Set srcShp = srcPag.Shapes.ItemFromID(12)
Set vPags = vDoc.Pages
pastedScopeID = Application.BeginUndoScope("Paste to page")
srcShp.Copy
targetPag.Paste
Application.EndUndoScope pastedScopeID, True
End Sub
Private Sub vPags_ShapeAdded(ByVal shp As IVShape)
If shp.Application.IsInScope(pastedScopeID) Then
Debug.Print "Application.CurrentScope " & Application.CurrentScope
Debug.Print "ShapeAdded - " & shp.NameID & " on page " & shp.ContainingPage.Name
DoSomethingToPastedShape shp
Else
Debug.Print "Application.CurrentScope " & Application.CurrentScope
End If
End Sub
Private Sub DoSomethingToPastedShape(ByVal shp As Visio.Shape)
If Not shp Is Nothing Then
shp.CellsU("FillForegnd").FormulaU = "=RGB(200, 30, 30)"
End If
End Sub
Of course you get error "Invalid sheet identifier" ! Because at "Page-1" you can have shape with ShapeID, which you defined for shape placed at "Page-2".
You can paste shape and after this step define selected shape.
Application.ActiveDocument.Pages.ItemU("Page-1").Paste
' You can define this variable as shape which is selected
Set Shape = Application.ActiveWindow.Selection.PrimaryItem
Why you use variable two times ?
I haven’t found a great way to handle this. I have a method that will paste the clipboard to a page and return any new shapes, by listing all shape ids before and after pasting, and then returning new shapes.
If speed is a big issue for me I’ll usually paste to an empty hidden page, do whatever I have to on that page, then cut and paste in place on the destination page. If you need to glue with other shapes this wouldn’t really work, but when it makes sense I use this logic.
Instead of Duplicate&Cut&Paste, just use Drop:
Dim srcShape, dstShape as Shape
Set srcShape = ActiveDocument.Pages("Page-2").Shapes("srcShape")
Set dstShape = ActiveDocument.Pages("Page-1").Drop(srcShape, 0, 0)
After the above you can access dstShape and do with it whatever you want.

Update existing PowerPoint from data in Excel

My intention is to open an existing PowerPoint presentation along with an existing Excel workbook, and subsequently run a VBA macro from Excel which would update the corresponding values in PowerPoint.
For this I've identified the Shape name of the corresponding text boxes I want to update in PowerPoint by highlighting the specific textbox and used Format -> Align. Then I've created 3 columns in Excel with the values:
Slide index Shape name Value
1 Title 2 =CONCATENATE("REPORT ";YEAR(TODAY()))
1 Placeholder for date1 =TODAY()
I use the macro (which I unfortunately can't remember from which site I copied it):
Sub writedata()
Dim c As Object
Dim shapeslide
Dim shapename
Dim shapetext
Set ppapp = GetObject(, "Powerpoint.application")
Set pppres = ppapp.ActivePresentation
For Each c In Blad2.Range("a2:a" & Blad2.Range("a" & Rows.Count).End(xlUp).Row)
shapeslide = Blad2.Range("a" & c.Row)
shapename = Blad2.Range("b" & c.Row)
shapetext = Blad2.Range("c" & c.Row).Text
pppres.Slides(shapeslide).Shapes(shapename).TextEffect.Text = shapetext
Next
End Sub
My problem is that Slide 1 wont be updated at all in its corresponding Shape name. The only action which happens when I execute this macro is that, for some reason, Slide 3 has its font size modified to become size 35 instead of size 16. I can't understand why that is happening. The Shape name of the shape whose font size is altered is neither written into the Excel workbook, nor is it the same shape name as one of those two written in Excel.
Hopefully someone can shed some light into this.
Lets get your slides and shapes listed by excel to ensure that they are what you expect. Sometimes they are really oddly named/IDed. Since you have slides not changing that should and slides changing that should not... we definitely need to doublecheck these. This will itterate through each slide and each shape on that slide and list the slide ID and Name and each shape ID and Name. I have a presentation and the first slide is slide 297 for some reason. Then slide 250 is second. Slide 50 is 3rd. The rest are all numbered oddly also. o.O
Turn on your immediates window to see the debug text.
Sub SlidesShapes()
Dim i As Integer, j As Integer
Set ppapp = GetObject(, "PowerPoint.Application")
Set ppres = ppapp.ActivePresentation
For i = 1 To ppres.Slides.Count'slides and shapes start counting at 1 not 0
Debug.Print ppres.Slides(i).SlideID
Debug.Print ppres.Slides(i).Name
For j = 1 To ppres.Slides(i).Shapes.Count
Debug.Print ppres.Slides(i).Shapes(j).ID
Debug.Print ppres.Slides(i).Shapes(j).Name
Next
Next
End Sub
Also, when you step through your original code (not this snippet) what do you see in your locals window for each step? Anything weird going on there that jumps out at you? Any variables populated with something unexpected or not completely right?

Create animated random image display tool in VBA

I have a PowerPoint slide with different images. I need to create VBA code in PowerPoint that recognises all these images and fades them out one by one - except for one randomly chosen image. This last image should remain until the end, then fade out and display in the middle of the slide.
I have an idea of how to do it and have experience with object oriented languages (R) but I have never used VBA before. Therefore I would be grateful for pointers on how to do any of the following in VBA:
Determine number of images on active slide
Select each image one after another and assign a counter variable as selection label (that part should work as described here)
Create "Range A" of all assigned counter variables
Select random number "x" in "Range A"
Create "Range B" of all counter variables in "Range A" EXCEPT for the random number "x"
Randomise the order of variables in "Range B"
Loop through "Range B" and fade out images whose label corresponds to the respective "Range B" variable that comes up
Fade out the image whose label corresponds to "x"
Insert the image whose label corresponds to "x" in the centre of the slide
If it is very difficult to recognise images or assign labels to those images I can also do so manually. However, it would be nicer if that could happen automatically. I would be grateful for any pointers, also in the form of links if you think that part of the above process is already described somewhere else (I'm afraid since I'm inexperienced in VBA I am not using very effective search terms).
EDIT:
Please find the solution (steps 8 and 9 are still missing)
Sub SelectionMacro()
Dim oSl As Slide
Dim oSh As Shape
Dim aArrayOfShapes() As Variant
Dim ShapeX As Shape
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim FadeEffect As Effect
Set oSl = ActivePresentation.SlideS(1)
'This section creates an array of all pictures on Slide1 called
'"aArrayOfShapes"
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes) + 1)
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next
'This section creates a random index number within the bounds of the
'length of aArrayOfShapes and assigns the shape with that index number
'to the Shape object ShapeX
Randomize
NumberX = Int((UBound(aArrayOfShapes) - (LBound(aArrayOfShapes) - 1)) * Rnd) + LBound(aArrayOfShapes)
Set ShapeX = aArrayOfShapes(NumberX)
'This section shuffles aArrayOfShapes
For N = LBound(aArrayOfShapes) To UBound(aArrayOfShapes)
J = CLng(((UBound(aArrayOfShapes) - N) * Rnd) + N)
If N <> J Then
Set Temp = aArrayOfShapes(N)
Set aArrayOfShapes(N) = aArrayOfShapes(J)
Set aArrayOfShapes(J) = Temp
End If
Next N
'This section loops through all Shapes in aArrayOfShapes and
'fades them out one by one EXCEPT for ShapeX
For Each Shape In aArrayOfShapes
If ShapeX.Name <> Shape.Name Then
Set FadeEffect = oSl.TimeLine.MainSequence.AddEffect _
(Shape:=Shape, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerAfterPrevious)
With FadeEffect
.Timing.Duration = 0.5
.Exit = msoTrue
End With
End If
Next Shape
End Sub
In order to reset the slide to the state before running the macro (so as to be able to run it again and display another random image) the following macro needs to be run:
Sub ResetSelection()
For i = ActivePresentation.SlideS(1).TimeLine.MainSequence.Count To 1 Step -1
ActivePresentation.SlideS(1).TimeLine.MainSequence(i).Delete
Next i
End Sub
Working out the range of images shouldn't be too hard. This'll get you started.
Assigning animation to shapes can be tricky. You might be better off duplicating the slide with all the images then deleting all but a randomly chosen image.
Dim oSl As Slide
Dim oSh As Shape
' Dynamic array of shapes to hold shape references
Dim aArrayOfShapes() As Shape
Set oSl = ActiveWindow.Selection.SlideRange(1)
For Each oSh In oSl.Shapes
If oSh.Type = msoPicture Then
On Error Resume Next
Debug.Print UBound(aArrayOfShapes)
If Err.Number = 0 Then
ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes))
Else
ReDim Preserve aArrayOfShapes(1 To 1)
End If
Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
End If
Next`enter code here`
' Now you have an array containing references to all the pictures
' on the slide. You can use a random number function to return
' an index into the array to choose a picture at random.
With aArrayOfShapes(RandomNumberFunction(LBound(aArrayOfShapes), UBound(aArrayOfShapes)))
' google to find an appropriate function; they're out there
' do whatever you need to do with your shapes here
End With