macro and animation problem?

[Geoff Cox]

Hello,

The basic problem is that a macro which works in the ppt file within
which it is created, will not carry over some animation when it is
used in bigger macro which works with many files ...

When I run this macro (created using the record macro in PPT 2003) in
a ppt file with some other animation - just some text with a
dissolving entrance, it creates an animation button, with a hyperlink
to the menu.ppt file, which dissolves in after the above animation and
works fine.

Sub Macro2()
'
' Macro recorded 11/04/2006 by Geoff Cox
'


ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeActionButtonForwardorNext,
246.62, 332.38, 209.75, 39.62).Select
With
ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseClick)
.Hyperlink.Address = "C:\fred\menu.ppt"
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoTrue
End With
With ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseOver)
.Action = ppActionNone
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse
End With
End Sub


But But But!

When I use the code below which puts the action button on the last
slide of a series of presentations, using more or less the same code
as above in the sub Mymacro, I get the action button on each of the
last slides but the dissolve animation for the button does not work.

Any ideas why?

Cheers

Geoff


Sub ForEachPresentation()
' Run a macro of your choosing on each presentation in a folder

Dim rayFileList() As String
Dim FolderPath As String
Dim FileSpec
Dim strTemp As String
Dim x As Long

' EDIT THESE to suit your situation
FolderPath = "c:\fred\activities\" ' Note: MUST end in \
FileSpec = "*.ppt"
' END OF EDITS

' Fill the array with files that meet the spec above
ReDim rayFileList(1 To 1) As String
strTemp = Dir$(FolderPath & FileSpec)
While strTemp <> ""
rayFileList(UBound(rayFileList)) = FolderPath & strTemp
ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1) As
String
strTemp = Dir
Wend

' array has one blank element at end - don't process it
' don't do anything if there's less than one element
If UBound(rayFileList) > 1 Then
For x = 1 To UBound(rayFileList) - 1
Call MyMacro(rayFileList(x))
Next x
End If

End Sub

Sub MyMacro(strMyFile As String)
' this gets called once for each file that meets the spec you enter in
ForEachPresentation
' strMyFile is set to the file name each time

' Probably at a minimum, you'd want to:
Dim oPresentation As Presentation
Set oPresentation = Presentations.Open(strMyFile)

With oPresentation


ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeActionButtonForwardorNext,
189.88, 389.12, 153.12, 39.62).Select
With
ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseClick)
.Hyperlink.Address = "C:\fred\menu.ppt"
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoTrue
End With
With ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseOver)
.Action = ppActionNone
.SoundEffect.Type = ppSoundNone
.AnimateAction = msoFalse

End With

oPresentation.Save
oPresentation.Close

End With
End Sub