众所周知ppt原生的动画太过拉跨。特别是直线动画，刹车非常慢且无法调节，强行缩短时间又直接砍掉刹车效果等等。此处纯vba动画是逐帧绘制，所以理论上能提供远超原生动画的效果，甚至达到ae那种效果也是有可能的 : )

先放一个最常见的方法。运行可看到“对象名”形状向右移动100磅（约3.5cm）

Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long Dim t As Single Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名)'需要手动设定 for i = 1 to 100 t = Timer shp.left = shp.left + 1 Do While Timer < t + 0.01 DoEvents ' 持续刷新界面 Loop next

很多人说在新版这种用不了了（excel还能）。新版ppt更改渲染机制，将间隔短的变更全部打包到一起。导致动画非常卡甚至不动。这里分享一种新方法，不用外挂，仅强制刷新界面

Sub Test() Dim idx As Long Dim t As Single Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes("a") '需要手动设定 For i = 1 To 100 t = Timer shp.Left = shp.Left + 1 t = Timer Do While Timer < t + 0.01 DoEvents ' 持续刷新界面 idx = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex ActivePresentation.SlideShowWindow.View.GotoSlide idx Loop Next End Sub

运行示例

这里是通过gotoslide强制刷新。gotoslide优先级在打包渲染之上，所以能覆盖掉ppt原有规则

通过这个，我们还能实现ppt原生无法实现的急刹移动，平滑放大等。效果非常不错。这边放一个示例动画，完全基于vba实现无外挂

（注：看起来卡是录屏原因。实测这种动画达到60帧完全没问题！）

代码比较复杂，这里免费放一个打包好的 ：）

Private Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long Sub Delay(ms As Long) Dim t As Single t = Timer Do While Timer < t + ms / 1000 DoEvents ' 持续刷新界面 RefreshSlideShow Loop End Sub Sub RefreshSlideShow() Dim idx As Long idx = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex ActivePresentation.SlideShowWindow.View.GotoSlide idx End Sub Sub Move1(对象名 As String, 结束坐标X As Double, 结束坐标Y As Double, 衰减系数 As Double, 帧率 As Long) 结束坐标X = 结束坐标X * 28.346457 结束坐标Y = 结束坐标Y * 28.346457 Dim startL As Double Dim startT As Double Dim deltaL As Double Dim deltaT As Double Dim movedelay As Long Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) movedelay = 1000 / 帧率 startL = shp.Left startT = shp.Top deltaL = 结束坐标X - startL deltaT = 结束坐标Y - startT Do If Not deltaL = 0 Then shp.Left = shp.Left + (deltaL / 衰减系数) deltaL = deltaL / 衰减系数 End If If Not deltaT = 0 Then shp.Top = shp.Top + (deltaT / 衰减系数) deltaT = deltaT / 衰减系数 End If deltaL = 结束坐标X - shp.Left deltaT = 结束坐标Y - shp.Top Delay movedelay If (Abs(deltaT) < 0.2) And (Abs(deltaL) < 0.2) Then Exit Do End If Loop shp.Left = 结束坐标X shp.Top = 结束坐标Y End Sub Sub SetPosition(对象名 As String, X As Double, Y As Double) X = X * 28.346457 Y = Y * 28.346457 Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) shp.Left = X shp.Top = Y End Sub Sub 渐显移动(对象名 As String, 起始x As Double, 起始y As Double, 终止x As Double, 终止y As Double, 衰减系数 As Double, 渐显系数 As Double, 帧率 As Long) Call SetPosition(对象名, 起始x, 起始y) Dim i i = 1 起始x = 起始x * 28.346457 起始y = 起始y * 28.346457 终止x = 终止x * 28.346457 终止y = 终止y * 28.346457 Dim startL As Double Dim startT As Double Dim deltaL As Double Dim deltaT As Double Dim movedelay As Long Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) movedelay = 1000 / 帧率 startL = shp.Left startT = shp.Top deltaL = 终止x - startL deltaT = 终止y - startT Do i = i - 渐显系数 If i <= 0 Then shp.Fill.Transparency = 0 Else shp.Fill.Transparency = i End If If Not deltaL = 0 Then shp.Left = shp.Left + (deltaL / 衰减系数) deltaL = deltaL / 衰减系数 End If If Not deltaT = 0 Then shp.Top = shp.Top + (deltaT / 衰减系数) deltaT = deltaT / 衰减系数 End If deltaL = 终止x - shp.Left deltaT = 终止y - shp.Top Delay movedelay If (Abs(deltaT) < 0.2) And (Abs(deltaL) < 0.2) Then Exit Do End If Loop shp.Left = 终止x shp.Top = 终止y End Sub Sub SetSize(对象名 As String, W As Double, H As Double) Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) H = H * 28.346457 W = W * 28.346457 shp.Height = H shp.Width = W End Sub Sub setSH(对象名 As String, 透明度 As Double) Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) shp.Fill.Transparency = 透明度 End Sub Sub CHsize(对象名 As String, 结束宽W As Double, 结束高H As Double, 衰减系数 As Double, 帧率 As Long) 结束宽W = 结束宽W * 28.346457 结束高H = 结束高H * 28.346457 Dim startH As Double Dim startW As Double Dim deltaH As Double Dim deltaW As Double Dim movedelay As Long Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) movedelay = 1000 / 帧率 startH = shp.Height startW = shp.Width deltaH = 结束高H - startH deltaW = 结束宽W - startW Do If Not deltaH = 0 Then shp.Height = shp.Height + (deltaH / 衰减系数) deltaH = deltaH / 衰减系数 End If If Not deltaW = 0 Then shp.Width = shp.Width + (deltaW / 衰减系数) deltaW = deltaW / 衰减系数 End If deltaH = 结束高H - shp.Height deltaW = 结束宽W - shp.Width Delay movedelay If (Abs(deltaW) < 0.2) And (Abs(deltaH) < 0.2) Then Exit Do End If Loop shp.Height = 结束高H shp.Width = 结束宽W End Sub Sub Show2(对象名 As String, 始透明度 As Double, 末透明度 As Double, 衰减系数 As Double, 帧率 As Long) Dim movedelay As Long Call setSH(对象名, 始透明度) Set sld = ActivePresentation.SlideShowWindow.View.Slide Set shp = sld.Shapes(对象名) movedelay = 1000 / 帧率 Dim dti As Double dti = 末透明度 - 始透明度 Do shp.Fill.Transparency = shp.Fill.Transparency + (dti / 衰减系数) dti = 末透明度 - shp.Fill.Transparency If Abs(dti) <= 0.02 Then Exit Do End If Delay movedelay Loop End Sub

使用方法：把这些全复制进去。新开一个sub 输入call ······调用

比如上面那个动画，只需要这样写

Call Move1("a", 0, 0, 7, 400) Call CHsize("a", 33.867, 19.05, 7, 400) Delay 500 Call CHsize("a", 3, 3, 7, 400) Call Move1("a", 15.43, 8.03, 7, 400) Delay 500

其中move是移动，chsize是平滑放大。四个值分别对应终止坐标xy，系数（越大越平滑），帧率（设60帧会有点卡，所以尽量大点，但不能超过500帧）

感谢阅读！