创意代码分享——PPT图表动画

user_heztsaqv · 2016-4-12 13:27:51

十年前的今天，我在PPT学习论坛.Net注册，自此，开始了狂热的Excel学习；之后不久，又发现PowerPoint也是一个迷人的世界，于是同时也开始对PowerPoint的学习。相对于Excel来讲，老版本的PowerPoint能做的真是少之又少，但是随着版本的升级，PowerPoint的内容也迅速地丰富起来，特别是PowerPoint里面的动画，简直让人着迷！当然，PowerPoint里面还有很多很多不那么理想的东西，特别是，很多东西无法通过手动实现，又或者说动画就像以前的胶片电影一样，一个小动作是成百上千张照片逐帧出现的——一般人哪有这个精力、能力制作精美的动画啊？于是想到编程，一个复杂的动画，手动制作或许得几天时间；如果找到其数学模型，那么用编程来实现只是几秒钟的事情！PowerPoint对图表的动画支持远远不够，我们可以利用图形来制作“假”图表，这样的图表可以做得非常漂亮，动画实现随心所欲，我们的演讲也会因此而非常有逻辑，非常吸引观众！这是我去年开发的代码，放在这里，有点基础的人一看就明白。所以，我要说的是，分享代码不是什么，关键是创意！以此纪念我步入MS Office江湖的十周年！
[code=vb]
Option Explicit Dim sldTemp As Slide
Dim shpPointStyle As Shape
Dim shpTemp As Shape Private Sub cbbPointStyle_Change()
On Error Resume Next
With Me
If .mpReference.Value = 0 Then
.lstAllShapes.Clear
.lstRefShapes.Clear
With .lstAllShapes
For Each shpTemp In sldTemp.Shapes
If shpTemp.Name Me.cbbPointStyle.Text Then
.AddItem shpTemp.Name
End If
Next
End With
Else
.cbbFreeform.Clear
With .cbbFreeform
For Each shpTemp In sldTemp.Shapes
If shpTemp.Name Me.cbbPointStyle.Text Then
.AddItem shpTemp.Name
End If
Next
.ListIndex = 0
End With
End If
End With
End Sub Private Sub cbbSlide_Change()
On Error GoTo errHandler
Set sldTemp = ActivePresentation.Slides(Me.cbbSlide.ListIndex + 1)
sldTemp.Select
With Me.cbbPointStyle
.Clear
For Each shpTemp In sldTemp.Shapes
.AddItem shpTemp.Name
Next
.ListIndex = 0
End With
Exit Sub
errHandler:
If Err.Number = 380 Then
MsgBox "所选幻灯片上面没有图形。请另选其它幻灯片。", vbCritical, "错误"
Else
End If
End Sub Private Sub cbKeepLine_Click()
With Me
.cmdLineColor.Enabled = .cbKeepLine.Value
.txtR.Enabled = .cbKeepLine.Value
.txtG.Enabled = .cbKeepLine.Value
.txtB.Enabled = .cbKeepLine.Value
.txtLineWeight.Enabled = .cbKeepLine.Value
End With
End Sub [/code]
为了方便网友，我将窗体界面和代码直接打包上传。

frmChartAnimPoints.zip (3.52 KB, 下载次数: 135)

user_ssljc · 2016-4-12 14:29:07

重新贴代码：
[code=vb]Option Explicit
Dim sldTemp As Slide
Dim shpPointStyle As Shape
Dim shpTemp As Shape
Private Sub cbbPointStyle_Change()
On Error Resume Next
With Me
      If .mpReference.Value = 0 Then
         .lstAllShapes.Clear
         .lstRefShapes.Clear
         With .lstAllShapes
            For Each shpTemp In sldTemp.Shapes
                  If shpTemp.Name <> Me.cbbPointStyle.Text Then
                     .AddItem shpTemp.Name
                  End If
            Next
         End With
      Else
         .cbbFreeform.Clear
         With .cbbFreeform
            For Each shpTemp In sldTemp.Shapes
                  If shpTemp.Name <> Me.cbbPointStyle.Text Then
                     .AddItem shpTemp.Name
                  End If
            Next
            .ListIndex = 0
         End With
      End If
End With
End Sub
Private Sub cbbSlide_Change()
On Error GoTo errHandler
Set sldTemp = ActivePresentation.Slides(Me.cbbSlide.ListIndex + 1)
sldTemp.Select
With Me.cbbPointStyle
      .Clear
      For Each shpTemp In sldTemp.Shapes
         .AddItem shpTemp.Name
      Next
      .ListIndex = 0
End With
Exit Sub
errHandler:
If Err.Number = 380 Then
      MsgBox "所选幻灯片上面没有图形。请另选其它幻灯片。", vbCritical, "错误"
Else

End If
End Sub
Private Sub cbKeepLine_Click()
With Me
      .cmdLineColor.Enabled = .cbKeepLine.Value
      .txtR.Enabled = .cbKeepLine.Value
      .txtG.Enabled = .cbKeepLine.Value
      .txtB.Enabled = .cbKeepLine.Value
      .txtLineWeight.Enabled = .cbKeepLine.Value
End With
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub[/code]

哎呀呀 · 2016-4-12 14:34:10

[code=vb]Private Sub cmdOK_Click()
'计数器
Dim i As Integer
Dim j As Integer
Dim iPoints As Integer
Dim iNodesCount As Integer

Dim shpPointTemp As Shape

Dim bfTemp As FreeformBuilder
Dim shpFreeform As Shape
Dim bBessel As Boolean

Dim effTemp As Effect
Dim bhvTemp As AnimationBehavior
Dim sinX0 As Single
Dim sinY0 As Single
Dim sinX1 As Single
Dim sinY1 As Single
Dim sinX2 As Single
Dim sinY2 As Single
Dim sinX3 As Single
Dim sinY3 As Single

Dim sinSldWidth As Single
Dim sinSldHeight As Single

Dim strVMLPath As String

Set sldTemp = ActivePresentation.Slides(Me.cbbSlide.ListIndex + 1)
With sldTemp
      On Error GoTo errHandler
      sinSldWidth = .Master.Width
      sinSldHeight = .Master.Height

      Set shpPointStyle = .Shapes(Me.cbbPointStyle.Text)

      If Me.mpReference.Value = 0 Then
'基于用户指定的数据点设置图表动画
         bBessel = Me.optBessel.Value
         iPoints = Me.lstRefShapes.ListCount
         Set shpTemp = .Shapes(Me.lstRefShapes.List(0))
         '根据用户提供的数据点，绘制自由曲线或者折线
         Set bfTemp = .Shapes.BuildFreeform(msoEditingAuto, _
                                 shpTemp.Left + shpTemp.Width / 2, _
                                 shpTemp.Top + shpTemp.Height / 2)
         For i = 1 To iPoints - 1
            Set shpTemp = .Shapes(Me.lstRefShapes.List(i))
            If Me.optBessel Then
                  bfTemp.AddNodes msoSegmentCurve, msoEditingAuto, _
                        shpTemp.Left + shpTemp.Width / 2, _
                        shpTemp.Top + shpTemp.Height / 2
            Else
                  bfTemp.AddNodes msoSegmentLine, msoEditingAuto, _
                        shpTemp.Left + shpTemp.Width / 2, _
                        shpTemp.Top + shpTemp.Height / 2
            End If
         Next i
         Set shpFreeform = bfTemp.ConvertToShape
         With shpFreeform.Line
            .Visible = msoTrue
            .Weight = Me.txtLineWeight
            .ForeColor.RGB = RGB(Me.txtR.Text, Me.txtG.Text, Me.txtB.Text)
         End With
         '将数据标志移动到系列线上面
         shpPointStyle.ZOrder msoBringToFront
      Else
'基于用户指定的自由曲线设置图表动画
         Set shpFreeform = .Shapes(Me.cbbFreeform.Text)
         With shpFreeform
            '指定图形是否是自由曲线，如果节点数为0则否，报错
            If .Nodes(1).SegmentType = msoSegmentCurve Then
                  bBessel = True
            Else
                  bBessel = False
            End If
         End With
      End If
      iNodesCount = shpFreeform.Nodes.Count

      If bBessel Then
      '贝塞尔曲线轨迹动画
         strVMLPath = "M 0 0 C "
         If Me.optOnePoint.Value Then
         '如果只有一个数据标志
            With shpFreeform
                  shpPointStyle.Left = .Nodes(1).Points(1, 1) - shpPointStyle.Width / 2
                  shpPointStyle.Top = .Nodes(1).Points(1, 2) - shpPointStyle.Height / 2
                  sinX0 = .Nodes(1).Points(1, 1)
                  sinY0 = .Nodes(1).Points(1, 2)
                  For i = 1 To VBA.Int(iNodesCount / 3)
                     sinX1 = .Nodes(3 * (i - 1) + 2).Points(1, 1)
                     sinY1 = .Nodes(3 * (i - 1) + 2).Points(1, 2)
                     sinX2 = .Nodes(3 * (i - 1) + 3).Points(1, 1)
                     sinY2 = .Nodes(3 * (i - 1) + 3).Points(1, 2)
                     sinX3 = .Nodes(3 * (i - 1) + 4).Points(1, 1)
                     sinY3 = .Nodes(3 * (i - 1) + 4).Points(1, 2)
                     strVMLPath = strVMLPath & (sinX1 - sinX0) / sinSldWidth & " " & (sinY1 - sinY0) / sinSldHeight & " " _
                                                & (sinX2 - sinX0) / sinSldWidth & " " & (sinY2 - sinY0) / sinSldHeight & " " _
                                                & (sinX3 - sinX0) / sinSldWidth & " " & (sinY3 - sinY0) / sinSldHeight & IIf(i < VBA.Int(iNodesCount / 3), " C ", " E")
                  Next i
            End With
            '设置动画
            Set effTemp = .TimeLine.MainSequence.AddEffect( _
                                                      Shape:=shpPointStyle, _
                                                      effectid:=msoAnimEffectCustom, _
                                                      trigger:=msoAnimTriggerOnPageClick)
            With effTemp
                  Set bhvTemp = .Behaviors.Add(msoAnimTypeProperty)
                  With bhvTemp
                     With .Timing
                        .Duration = 1
                        .TriggerDelayTime = 0
                     End With
                     With .PropertyEffect
                        .Property = msoAnimOpacity
                        .From = 0
                        .To = 1
                     End With
                  End With
                  Set bhvTemp = .Behaviors.Add(msoAnimTypeMotion)
                  With bhvTemp
                     With .Timing
                        .Duration = 4
                        .TriggerDelayTime = 1
                     End With
                     With .MotionEffect
                        .Path = strVMLPath
                     End With
                  End With
            End With
         Else
         '保留所有数据标志
            For j = 1 To VBA.Int(iNodesCount / 3) + 1
                  strVMLPath = "M 0 0 C "
                  If j = 1 Then
                     '复制数据标志，并将其移动到相应位置
                     Set shpPointTemp = shpPointStyle.Duplicate.Item(1)
                     With shpPointTemp
                        .Name = "shpPoint" & j
                        .Left = shpFreeform.Nodes(1).Points(1, 1) - .Width / 2
                        .Top = shpFreeform.Nodes(1).Points(1, 2) - .Width / 2
                     End With
                     '第一个数据点的动画只是淡入
                     Set effTemp = .TimeLine.MainSequence.AddEffect( _
                                          Shape:=shpPointTemp, _
                                          effectid:=msoAnimEffectCustom, _
                                          trigger:=msoAnimTriggerOnPageClick)
                     With effTemp
                        Set bhvTemp = .Behaviors.Add(msoAnimTypeProperty)
                        With bhvTemp
                              With .Timing
                                 .Duration = 1
                              End With
                              With .PropertyEffect
                                 .Property = msoAnimOpacity
                                 .From = 0
                                 .To = 1
                              End With
                        End With
                     End With
                  Else
                     '复制数据标志，并将其移动到相应位置
                     Set shpPointTemp = shpPointStyle.Duplicate.Item(1)
                     With shpPointTemp
                        .Name = "shpPoint" & j
                        .Left = shpFreeform.Nodes(3 * (j - 2) + 1).Points(1, 1) - .Width / 2
                        .Top = shpFreeform.Nodes(3 * (j - 2) + 1).Points(1, 2) - .Width / 2
                     End With
                     '第二个以及后面的数据点的动画
                     '从前面数据点的位置淡入，然后移动到目标位置
                     Set effTemp = .TimeLine.MainSequence.AddEffect( _
                                          Shape:=shpPointTemp, _
                                          effectid:=msoAnimEffectCustom, _
                                          trigger:=msoAnimTriggerAfterPrevious)
                     With effTemp
                        Set bhvTemp = .Behaviors.Add(msoAnimTypeProperty)
                        With bhvTemp
                              With .Timing
                                 .Duration = 0.1
                              End With
                              With .PropertyEffect
                                 .Property = msoAnimOpacity
                                 .From = 0
                                 .To = 1
                              End With
                        End With
                        With shpFreeform
                              sinX0 = .Nodes(3 * (j - 2) + 1).Points(1, 1)
                              sinY0 = .Nodes(3 * (j - 2) + 1).Points(1, 2)
                              sinX1 = .Nodes(3 * (j - 2) + 2).Points(1, 1)
                              sinY1 = .Nodes(3 * (j - 2) + 2).Points(1, 2)
                              sinX2 = .Nodes(3 * (j - 2) + 3).Points(1, 1)
                              sinY2 = .Nodes(3 * (j - 2) + 3).Points(1, 2)
                              sinX3 = .Nodes(3 * (j - 2) + 4).Points(1, 1)
                              sinY3 = .Nodes(3 * (j - 2) + 4).Points(1, 2)
                        End With
                        strVMLPath = strVMLPath & (sinX1 - sinX0) / sinSldWidth & " " & (sinY1 - sinY0) / sinSldHeight & " " _
                                                      & (sinX2 - sinX0) / sinSldWidth & " " & (sinY2 - sinY0) / sinSldHeight & " " _
                                                      & (sinX3 - sinX0) / sinSldWidth & " " & (sinY3 - sinY0) / sinSldHeight & " E"
'                         Debug.Print j & ": " & strVMLPath
                        Set bhvTemp = .Behaviors.Add(msoAnimTypeMotion)
                        With bhvTemp
                              With .Timing
                                 .Duration = 0.9
                                 .TriggerDelayTime = 0.1
                              End With
                              With .MotionEffect
                                 .Path = strVMLPath
                              End With
                        End With
                     End With
                  End If
            Next j
         End If
      Else[/code]

user_mxvpz · 2016-4-12 14:37:13

'折线轨迹动画
strVMLPath = "M 0 0 L "
If Me.optOnePoint.Value Then
'如果只有一个数据标志
With shpFreeform
shpPointStyle.Left = .Nodes(1).Points(1, 1) - shpPointStyle.Width / 2
shpPointStyle.Top = .Nodes(1).Points(1, 2) - shpPointStyle.Height / 2
sinX0 = .Nodes(1).Points(1, 1)
sinY0 = .Nodes(1).Points(1, 2)
For i = 2 To iNodesCount
sinX1 = .Nodes(i).Points(1, 1)
sinY1 = .Nodes(i).Points(1, 2)
strVMLPath = strVMLPath & (sinX1 - sinX0) / sinSldWidth & " " & (sinY1 - sinY0) / sinSldHeight & IIf(i < iNodesCount, " L ", " E")
Next i
End With
'设置动画
Set effTemp = .TimeLine.MainSequence.AddEffect( _
Shape:=shpPointStyle, _
effectid:=msoAnimEffectCustom, _
trigger:=msoAnimTriggerOnPageClick)
With effTemp
Set bhvTemp = .Behaviors.Add(msoAnimTypeProperty)
With bhvTemp
With .Timing
.Duration = 1
.TriggerDelayTime = 0
End With
With .PropertyEffect
.Property = msoAnimOpacity
.From = 0
.To = 1
End With
End With
Set bhvTemp = .Behaviors.Add(msoAnimTypeMotion)
With bhvTemp
With .Timing
.Duration = 4
.TriggerDelayTime = 1
End With
With .MotionEffect
.Path = strVMLPath
End With
End With
End With
Else
'保留所有数据标志
For j = 1 To iNodesCount
strVMLPath = "M 0 0 L "
If j = 1 Then
'复制数据标志，并将其移动到相应位置
Set shpPointTemp = shpPointStyle.Duplicate.Item(1)
With shpPointTemp
.Name = "shpPoint" & j
.Left = shpFreeform.Nodes(1).Points(1, 1) - .Width / 2
.Top = shpFreeform.Nodes(1).Points(1, 2) - .Width / 2
End With
'第一个数据点的动画只是淡入
Set effTemp = .TimeLine.MainSequence.AddEffect( _
Shape:=shpPointTemp, _
effectid:=msoAnimEffectCustom, _
trigger:=msoAnimTriggerOnPageClick)
With effTemp
Set bhvTemp = .Behaviors.Add(msoAnimTypeProperty)
With bhvTemp
With .Timing
.Duration = 1
End With
With .PropertyEffect
.Property = msoAnimOpacity
.From = 0
.To = 1
End With
End With
End With
Else
'复制数据标志，并将其移动到相应位置
Set shpPointTemp = shpPointStyle.Duplicate.Item(1)
With shpPointTemp
.Name = "shpPoint" & j
.Select
.Left = shpFreeform.Nodes(j - 1).Points(1, 1) - .Width / 2
.Top = shpFreeform.Nodes(j - 1).Points(1, 2) - .Width / 2
End With
'第二个以及后面的数据点的动画
'从前面数据点的位置淡入，然后移动到目标位置
Set effTemp = .TimeLine.MainSequence.AddEffect( _
Shape:=shpPointTemp, _
effectid:=msoAnimEffectCustom, _
trigger:=msoAnimTriggerAfterPrevious)
With effTemp
Set bhvTemp = .Behaviors.Add(msoAnimTypeProperty)
With bhvTemp
With .Timing
.Duration = 0.1
End With
With .PropertyEffect
.Property = msoAnimOpacity
.From = 0
.To = 1
End With
End With
With shpFreeform
sinX0 = .Nodes(j - 1).Points(1, 1)
sinY0 = .Nodes(j - 1).Points(1, 2)
sinX1 = .Nodes(j).Points(1, 1)
sinY1 = .Nodes(j).Points(1, 2)
End With
strVMLPath = strVMLPath & (sinX1 - sinX0) / sinSldWidth & " " & (sinY1 - sinY0) / sinSldHeight & " E"
' Debug.Print j & ": " & strVMLPath
Set bhvTemp = .Behaviors.Add(msoAnimTypeMotion)
With bhvTemp
With .Timing
.Duration = 0.9
.TriggerDelayTime = 0.1
End With
With .MotionEffect
.Path = strVMLPath
End With
End With
End With
End If
Next j
End If
End If
If Me.mpReference.Value = 0 Then
'删除或者隐藏参考点
If MsgBox("删除或者隐藏用户指定的数据标志和数据标志样式？" & vbNewLine & vbNewLine & _
"点击Yes删除" & vbNewLine & "点击No隐藏", vbYesNo + vbDefaultButton1, "") = vbYes Then
If Me.optAllPoints.Value Then shpPointStyle.Delete
For i = 1 To Me.lstRefShapes.ListCount
.Shapes(Me.lstRefShapes.List(i - 1)).Delete
Next
Else
If Me.optAllPoints.Value Then shpPointStyle.Visible = msoFalse
For i = 1 To Me.lstRefShapes.ListCount
.Shapes(Me.lstRefShapes.List(i - 1)).Visible = msoFalse
Next
End If
Else
If Me.optAllPoints.Value Then
If MsgBox("删除或者隐藏用户指定的数据标志样式？" & vbNewLine & vbNewLine & _
"点击Yes删除" & vbNewLine & "点击No隐藏", vbYesNo + vbDefaultButton1, "") = vbYes Then
shpPointStyle.Delete
Else
shpPointStyle.Visible = msoFalse
End If
End If
End If
If Me.cbKeepLine.Value = False Then
shpFreeform.Visible = msoFalse
End If
End With
Unload Me
Exit Sub
errHandler:
If Err.Number = -2147024809 Then
MsgBox "用户指定的参考折线不是自由折线，没有节点。请指定合法自由曲线。", vbCritical, "参考折线错误"
Else
End If
Unload Me
End Sub
Private Sub lstAllShapes_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
With Me.lstRefShapes
.AddItem Me.lstAllShapes.Text
End With
End Sub
Private Sub lstRefShapes_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
With Me.lstRefShapes
.RemoveItem .ListIndex
End With
End Sub
Private Sub mpReference_Change()
With Me
If .mpReference.Value = 0 Then
.lstAllShapes.Clear
.lstRefShapes.Clear
With .lstAllShapes
For Each shpTemp In sldTemp.Shapes
If shpTemp.Name <> Me.cbbPointStyle.Text Then
.AddItem shpTemp.Name
End If
Next
End With
Else
.cbbFreeform.Clear
With .cbbFreeform
For Each shpTemp In sldTemp.Shapes
If shpTemp.Name <> Me.cbbPointStyle.Text Then
.AddItem shpTemp.Name
End If
Next
.ListIndex = 0
End With
End If
End With
End Sub
Private Sub optAllPoints_Click()
If Me.optAllPoints Then
Me.cbKeepLine.Enabled = True
End If
End Sub
Private Sub optOnePoint_Click()
If Me.optOnePoint.Value Then
Me.cbKeepLine.Value = False
Me.cbKeepLine.Enabled = False
Else
Me.cbKeepLine.Enabled = True
End If
End Sub
Private Sub txtB_Change()
With Me
If VBA.IsNumeric(.txtB.Text) Then
If .txtB.Value > 255 Then
.txtB.Text = 255
ElseIf .txtB.Value < 0 Then
.txtB.Text = 0
End If
Else
.txtB.Text = 0
End If
.cmdLineColor.BackColor = RGB(.txtR.Text, .txtG.Text, .txtB.Text)
End With
End Sub
Private Sub txtG_Change()
With Me
If VBA.IsNumeric(.txtG.Text) Then
If .txtG.Value > 255 Then
.txtG.Text = 255
ElseIf .txtG.Value < 0 Then
.txtG.Text = 0
End If
Else
.txtG.Text = 0
End If
.cmdLineColor.BackColor = RGB(.txtR.Text, .txtG.Text, .txtB.Text)
End With
End Sub
Private Sub txtR_Change()
With Me
If VBA.IsNumeric(.txtR.Text) Then
If .txtR.Value > 255 Then
.txtR.Text = 255
ElseIf .txtR.Value < 0 Then
.txtR.Text = 0
End If
Else
.txtR.Text = 0
End If
.cmdLineColor.BackColor = RGB(.txtR.Text, .txtG.Text, .txtB.Text)
End With
End Sub
Private Sub UserForm_Initialize()
Dim isldcount As Integer
Dim i As Integer
isldcount = ActivePresentation.Slides.Count
With Me
With .cbbSlide
For i = 1 To isldcount
.AddItem ActivePresentation.Slides(i).Name
Next i
.ListIndex = ActiveWindow.Selection.SlideRange.SlideNumber - 1
End With
.mpReference.Value = 0
End WithEnd Sub

复制代码

ckjd80 · 2016-4-12 14:38:26

好贴呀，只能说这个空洞的话来表达自己的心情

wdm2004 · 2016-4-12 14:48:00

很强大,VBA高手,谢谢!

izziexj · 2016-4-12 14:54:32

楼主辛苦了
学学

pp86pm95e · 2016-4-12 14:57:29

太厉害了。对我来说，简直就是天书！！！！

user_dnuha · 2016-4-12 15:04:00

奇怪，在VBE中怎么不能导入该窗体？

dilulu · 2016-4-12 15:13:35

真是高手，太强了！向LZ学习。

		自动登录	找回密码
密码			立即注册