This is the code that does the graphics. It does not always crash in the same
place, but usually fails after building this slide. Also after saving and
closing the presentation, I cannot get it to quit() (I open the PPT
application from Word VBA and no other presentations are open).
Public Sub cascade(myDoc As PowerPoint.Presentation, mySlide As
PowerPoint.Slide, arrGraphics() As typXTGraphic, bErase As Boolean, bFade As
Boolean, Optional intOffset As Integer = 0)
Dim myShape As PowerPoint.Shape
Dim oldshape As PowerPoint.Shape
'Dim tline As PowerPoint.TimeLine
Dim xtGraphic_rec As typXTGraphic
Dim rectShape As typRect
Dim rectGraphic As typRect
Dim myEntryEffect As PpEntryEffect
Dim myExitEffect As PpAfterEffect
On Error GoTo cascade_err
Set myShape = getShapewithTag(mySlide, "ppTag", "c1")
'establish the graphic's rectangle space by the shape dimensions
rectShape = setBoundsbyShape(myShape)
'removed the conditional for determining effect
myEntryEffect = ppEffectFade
myExitEffect = ppAfterEffectDim
torig = rectShape.T
lorig = rectShape.L
For i = 1 To UBound(arrGraphics)
strName = MergeReplace(myDoc.FullName, myDoc.Name, "graphics\" &
arrGraphics(i).Graphic_name)
Set myShape = mySlide.Shapes.AddPicture(FileName:=strName,
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=lorig + (i * offset),
Top:=torig + (i * offset), width:=arrGraphics(i).Graphic_Width,
height:=arrGraphics(i).Graphic_Height)
With rectShape
.T = .T + (intOffset)
.L = .L + (intOffset)
.W = .W - (intOffset)
.H = .H - (intOffset)
End With
sizeGraphictoPlaceHolder myShape, arrGraphics(i).Graphic_Width,
arrGraphics(i).Graphic_Height, rectShape
rectGraphic = setBoundsbyShape(myShape)
'if it is not offset then center it in the placeholder space
If intOffset = 0 Then
placeGraphic mySlide, myShape, rectShape, rectGraphic
Else
myShape.Left = rectShape.L
myShape.Top = rectShape.T
End If
With myShape.AnimationSettings
.Animate = msoTrue
.EntryEffect = myEntryEffect
.AdvanceMode = ppAdvanceOnClick
End With Set oldshape = myShape
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'next timing section commented until we can fix the crash
' With tline.MainSequence
' With .AddEffect(myShape, myEntryEffect)
' .Timing.Speed = 1
' End With
' If (i > 1) And (myExitEffect > 0) Then
'
' With .AddEffect(oldshape, myExitEffect)
' .Timing.TriggerType = msoAnimTriggerWithPrevious
' If (Not (bOffset)) Then .Exit = msoTrue
' End With
' End If
' End With
' Set oldshape = myShape
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
myDoc.Save
Next
Exit Sub
cascade_err:
MsgBox Err.Description
Resume Next
End Sub
