letp520 发表于 2016-4-12 13:32:31

求各位大佬帮忙写一个批量添加简单动画的VBA（有图，有文档）



如图，希望给带有【正确答案】和【答案解析】的这两段文字加上淡出的动画，目前有600多页ppt要加这种动画，未来还会有很多，求各位大佬们帮忙写一个VBA，谢谢了。

user_fqoqlawd 发表于 2016-4-12 16:38:29

没找到方法把文本框中的特定段落加上效果，换了另外一种思路，先把整个文本框设置“渐入”效果，再把不符合条件的效果从时间线的主序列中删掉。
注意，如果页面上已经存在的自定义动画会被删除。

Sub 多个页面插入文本动画()
    Dim sp As Shape, sld As Slide, teff As Effect, i As Integer, st As String
   
    '每个幻灯片循环一次
    For Each sld In ActivePresentation.Slides
      
      '每个图形循环一次
      For Each sp In sld.Shapes
            If sp.Type = msoShapeCube Or sp.Type = msoTextBox Then '如果是占位框或文本框
                If InStr(1, sp.AlternativeText, "【正确答案】", vbTextCompare) > 0 Then '如果包含文本“【正确答案】”
                  
                  '整个文本框加入效果，实际会出现一系列动画
                  sld.TimeLine.MainSequence.AddEffect sp, msoAnimEffectFade, msoAnimateTextByFirstLevel, msoAnimTriggerOnPageClick
                  'msoAnimEffectFade 加入“渐入”效果
                  'msoAnimateTextByFirstLevel 按照第一级段落处理
                  'msoAnimTriggerOnPageClick 点击幻灯片触发效果
                  
                  '从后向前处理各动画，如果不包含特定文字则删除效果
                  For i = sld.TimeLine.MainSequence.Count To 1 Step -1
                        Set teff = sld.TimeLine.MainSequence(i)
                        st = teff.DisplayName   'DisplayName是效果的显示名称，这里实际就是段落文字
                        If InStr(1, st, "【正确答案】", vbTextCompare) > 0 Or InStr(1, st, "【答案解析】", vbTextCompare) > 0 Then
                            teff.Timing.Duration = 0.5    '把效果的持续时间设为0.5秒（非常快）,也可设为1秒（快速）
                        Else
                            teff.Delete '删除效果
                        End If
                  Next
                End If
            End If
      Next
    Next
End Sub

user_rqebd 发表于 2016-4-12 17:00:17

非常感谢，帮大忙了

user_jscpf 发表于 2016-4-12 17:03:12

太强大了,能不能批量为多个本文加上链接?
页: [1]
查看完整版本: 求各位大佬帮忙写一个批量添加简单动画的VBA（有图，有文档）