创意代码分享——PPT图表动画
十年前的今天，我在PPT学习论坛.Net注册，自此，开始了狂热的Excel学习；之后不久，又发现PowerPoint也是一个迷人的世界，于是同时也开始对PowerPoint的学习。相对于Excel来讲，老版本的PowerPoint能做的真是少之又少，但是随着版本的升级，PowerPoint的内容也迅速地丰富起来，特别是PowerPoint里面的动画，简直让人着迷！当然，PowerPoint里面还有很多很多不那么理想的东西，特别是，很多东西无法通过手动实现，又或者说动画就像以前的胶片电影一样，一个小动作是成百上千张照片逐帧出现的——一般人哪有这个精力、能力制作精美的动画啊？于是想到编程，一个复杂的动画，手动制作或许得几天时间；如果找到其数学模型，那么用编程来实现只是几秒钟的事情！PowerPoint对图表的动画支持远远不够，我们可以利用图形来制作“假”图表，这样的图表可以做得非常漂亮，动画实现随心所欲，我们的演讲也会因此而非常有逻辑，非常吸引观众！ 这是我去年开发的代码，放在这里，有点基础的人一看就明白。所以，我要说的是，分享代码不是什么，关键是创意！ 以此纪念我步入MS Office江湖的十周年！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.NameMe.cbbPointStyle.Text Then
.AddItem shpTemp.Name
End If
Next
End With
Else
.cbbFreeform.Clear
With .cbbFreeform
For Each shpTemp In sldTemp.Shapes
If shpTemp.NameMe.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
为了方便网友，我将窗体界面和代码直接打包上传。
重新贴代码：
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 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
[*] '折线轨迹动画
[*] 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
复制代码 好贴呀，只能说这个空洞的话来表达自己的心情 很强大,VBA高手,谢谢! 楼主辛苦了
学学 太厉害了。对我来说，简直就是天书！！！！ 奇怪，在VBE中怎么不能导入该窗体？ 真是高手，太强了！向LZ学习。