docxueruizhi 发表于 2016-4-12 13:24:16

请问如何用VBA更改动画文本按字母延时百分比

在没有调整的情况下，vba生成的动画的字母延时是100延时，我希望只有10延时。请问VBA中应该怎么写呢？
因为希望动画自行添加并自行播放，所以使用了ANIMATIONSETTINGS，而没有使用addeffect。现在的vba代码如下：
Sub a1()
Dim doc As Slide, a As Variant, shp As Shape, text1$, shp_t As Variant
Set doc = ActivePresentation.Slides(1)
For Each a In doc.Shapes
a.Delete
Next
Set shp = doc.Shapes.AddShape(msoShapeRoundedRectangle, 10, 25, 200,100)
shp.Name = "3101"
shp.Line.Visible = msoFalse
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
text1 = "3101 B2051"
Set shp_t = shp.TextFrame2.TextRange
shp_t.Text = text1
shp_t.Font.Size = 24
shp_t.Font.Name = "Verdana"
With shp.AnimationSettings
.AdvanceMode = ppAdvanceOnTime
.AdvanceTime = 0
.EntryEffect = ppEffectSwivel
.TextLevelEffect = ppAnimateByFirstLevel
.TextUnitEffect = ppAnimateByCharacter
.Animate = msoTrue
End With
End Sub

user_tojoh 发表于 2016-4-12 14:42:35

动画效果很不错，但要正常运行好象要修改Set shp_t = shp.TextFrame2.TextRange
Sub a1()
Dim doc As Slide, a As Variant, shp As Shape, text1$,shp_t As Variant
Set doc = ActivePresentation.Slides(1)
For Each a In doc.Shapes
a.Delete
Next
Set shp = doc.Shapes.AddShape(msoShapeRoundedRectangle, 10, 25, 200,100)
shp.Name = "3101"
shp.Line.Visible = msoFalse
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
text1 = "3101 B2051"
Set shp_t = shp.TextFrame.TextRange
shp_t.Text = text1
shp_t.Font.Size = 24
shp_t.Font.Name = "Verdana"
With shp.AnimationSettings
    .AdvanceMode = ppAdvanceOnTime
    .AdvanceTime = 0
    .EntryEffect = ppEffectSwivel
    .TextLevelEffect = ppAnimateByFirstLevel
    .TextUnitEffect = ppAnimateByCharacter
    .Animate = msoTrue
End With
End Sub

user_kvnnb 发表于 2016-4-12 14:43:21

可能2010的代码和以前的有点不同吧。
继续求助中……

user_pdhvlzfc 发表于 2016-4-12 15:05:35

变通处理啊，vba中如果实在找不出字符延时的属性或方法的话，可以通过改变动画的速度来间接实现。我改写你这个代码如下：
Sub charEff()
    Dim iSld As Slide, allShp As Shape, newShp As Shape
    Randomize
    Set iSld = ActiveWindow.Selection.SlideRange(1)
    For i = iSld.Shapes.Count To 1 Step -1
      iSld.Shapes(i).Delete
    Next
    Set newShp = iSld.Shapes.AddShape(msoShapeRoundedRectangle, 10, 25, 200, 100)
    With newShp
      .Name = "3101"
      .Line.Visible = msoFalse
      .Fill.ForeColor.SchemeColor = ppForeground
      .Fill.Visible = msoFalse
      With .TextFrame.TextRange
            .Text = "3101 B2051"
            .Font.Size = 24
            .Font.Name = "Verdana"
            For i = 1 To Len(.Text)
                .Characters(i, 1).Font.Color.RGB = 16777216 * Rnd
            Next
      End With
    End With
    With newShp.AnimationSettings
      .AdvanceMode = ppAdvanceOnTime
      .AdvanceTime = 0
      .EntryEffect = ppEffectSwivel
      .TextLevelEffect = ppAnimateByFirstLevel
      .TextUnitEffect = ppAnimateByCharacter
      .Animate = msoTrue
    End With
    With iSld.TimeLine.MainSequence(1).Timing
      .Duration = 0.25
      .RepeatCount = 9999
      .Decelerate = 0.1
    End With
End Sub

user_ujwdsqxe 发表于 2016-4-12 15:13:34

感谢3楼的提点。在3楼的基础上做了些实验。虽然可以通过缩短时间来完成在固定时间内播放完动画。但不能做到前一个字母动画还没有完成的时候，下一个就已经开始。那种连续的变化和跳动的感觉似乎只能改变那个数字才可以。

user_yculd 发表于 2016-4-12 15:15:00

是的。手工修改下岂不是很简单。vba动画和常规动画在实现手段上不尽相同，取长补短吧。

ytyujia 发表于 2016-4-12 16:17:04

可惜。这本来是要写在EXCEL中，让EXCEL来控制PPT的。如今只能打折扣了。
感谢各位的帮助。现给出完整的代码。
另：本来想实现彩虹边框的，实在不会，只能转向用彩虹字了。电脑上只有PPT2010，PPT03的同志们需要稍微按照楼上的提示做一点修改。
Private r%, g%, bl%
Sub a1()
Dim sld As Slide, a As Variant, shp As Shape, text1$, n%, shp_t As Variant, h%
Set sld = ActivePresentation.Slides(1)
For Each a In sld.Shapes
a.Delete
Next
Set shp = sld.Shapes.AddShape(msoShapeRoundedRectangle, 10, 25, 200, 100)
shp.Visible = msoTrue
shp.Name = "3101"
shp.Line.Visible = msoFalse
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
text1 = "3101 B2051" & vbCrLf & "08:00201"
Set shp_t = shp.TextFrame2.TextRange
shp_t.Text = text1
shp_t.Font.Size = 24
shp_t.Font.Name = "Verdana"
For n = 1 To Len(text1) - 1
    If shp_t.Characters(n, 1) <> &quot; &quot; Then
      h = 360 / Len(text1) * n
      Call hsb2rgb(h, 0.8, 0.8)
      shp_t.Characters(n, 1).Font.Fill.ForeColor.RGB = RGB(r, g, bl)
    End If
Next
With shp.AnimationSettings
    .EntryEffect = ppEffectSwivel
    .AdvanceMode = ppAdvanceOnTime
    .AdvanceTime = 0
    .TextUnitEffect = ppAnimateByCharacter
    .Animate = msoTrue
End With
With sld.TimeLine.MainSequence(1).Timing
.Duration = 1.5
.Speed = 10
End With
End Sub
Sub hsb2rgb(h As Integer, s As Single, br As Single)
Dim hi%, p!, q!, t!, f!, v!
v = br
If v = 0 Then r = g = b = 0: Exit Sub
If s = 0 Then r = g = b = v * 255: Exit Sub
    hi = Int(h / 60)
    f = h / 60 - hi
    p = v * (1 - s)
    q = v * (1 - s * f)
    t = v * (1 - s * (1 - f))
    Select Case hi
    Case 0
      r = v * 255: g = t * 255: bl = p * 255
    Case 1
      r = q * 255: g = v * 255: bl = p * 255
    Case 2
      r = p * 255: g = v * 255: bl = t * 255
    Case 3
      r = p * 255: g = q * 255: bl = v * 255
    Case 4
      r = t * 255: g = p * 255: bl = v * 255
    Case 5
      r = v * 255: g = p * 255: bl = q * 255
    End Select
End Sub

laoz2onbv7 发表于 2016-4-12 16:54:22

学习下，PPT刚接触

fafa68868 发表于 2016-4-12 16:59:42

终于可以实现了：
Private r As Integer, g As Integer, b1 As Integer
Sub charEff()
    Dim iSld As Slide, allShp As Shape, newShp As Shape, i As Integer, h As Integer
    Set iSld = ActiveWindow.Selection.SlideRange(1)
    For i = iSld.Shapes.Count To 1 Step -1
      iSld.Shapes(i).Delete
    Next
    Set newShp = iSld.Shapes.AddShape(msoShapeRoundedRectangle, 10, 25, 200, 100)
    With newShp
      .Name = &quot;txtShp&quot;
      .Line.Visible = msoFalse
      .Fill.Visible = msoFalse
      With .TextFrame.TextRange
            .Text = &quot;3101 B2051&quot; & vbCrLf & &quot;08:00201&quot;
            .Font.Size = 24
            .Font.Name = &quot;Verdana&quot;
            For i = 1 To Len(.Text)
                If .Characters(i, 1) <> &quot; &quot; Then
                  h = 360 / Len(.Text) * i
                  Call hsb2rgb(h, 0.8, 0.8)
                  .Characters(i, 1).Font.Color.RGB = RGB(r, g, b1)
                End If
            Next
      End With
    End With
    With iSld.TimeLine.MainSequence
      .ConvertToTextUnitEffect .AddEffect(newShp, msoAnimEffectSwivel), msoAnimTextUnitEffectByCharacter
      .Item(1).Timing.Duration = 1
    End With
End Sub
Sub hsb2rgb(h As Integer, s As Single, br As Single)
    Dim hi As Integer, p As Single, q As Single, t As Single, f As Single, v As Single
    v = br
    If v = 0 Then r = g = b = 0: Exit Sub
    If s = 0 Then r = g = b = v * 255: Exit Sub
    hi = Int(h / 60)
    f = h / 60 - hi
    p = v * (1 - s)
    q = v * (1 - s * f)
    t = v * (1 - s * (1 - f))
    Select Case hi
    Case 0
      r = v * 255: g = t * 255: bl = p * 255
    Case 1
      r = q * 255: g = v * 255: bl = p * 255
    Case 2
      r = p * 255: g = v * 255: bl = t * 255
    Case 3
      r = p * 255: g = q * 255: bl = v * 255
    Case 4
      r = t * 255: g = p * 255: bl = v * 255
    Case 5
      r = v * 255: g = p * 255: bl = q * 255
    End Select
End Sub

baiselong 发表于 2016-4-12 17:09:43

非常感谢9楼的解答！一直以为duration只控制整个对象的动画长度，殊不知原来定义为字母动画后就是定义每个字母的动画长度了。
在此基础上，因为ADDEFFECT不能自动运行，需要加入一个隐形的形状引导需要显示的动画。隐形形状的动画设为自动，而字母旋转动画跟随上一个动画播放。
在此还要感谢9楼的解答。因为FOR EACH循环好像不能删除没有线条和填充的形状，只能用FOR NEXT删除。
但是我个人不喜欢在循环内调用对象，而比较喜欢使用简单的变量以增加速度。
不过9楼的变量定义有误，不知道是不是因为开头没有Option Explicit呢。
改进后的完整代码如下：
Option Explicit
Private r As Integer, g As Integer, bl As Integer
Sub charEff()
Dim Sld As Slide, Shp As Shape, shp_tmp As Shape, h As Integer, text1$, text1_len As Byte, n%
Set Sld = ActiveWindow.Selection.SlideRange(1)
For n = Sld.Shapes.Count To 1 Step -1 '删除页面上的所有形状
      Sld.Shapes(n).Delete
Next
Set Shp = Sld.Shapes.AddShape(msoShapeRoundedRectangle, 10, 25, 200, 100) '主要形状
Set shp_tmp = Sld.Shapes.AddShape(msoShapeRoundedRectangle, 4, 4, 4, 4) '需隐形的形状
With shp_tmp
    .Line.Visible = msoFalse '让形状不可见，用shp_tmp.visible=msofalse会导致动画添加的失败
    .Fill.Visible = msoFalse
End With
With Shp
      .Name = &quot;txtShp&quot;
      .Line.Visible = msoFalse
      .Fill.Visible = msoFalse
      With .TextFrame.TextRange
            text1 = &quot;3101 B2051&quot; & vbCrLf & &quot;08:00201&quot;
            text1_len = Len(text1) '把字符串长度写入变量
            .text = text1
            .Font.Size = 24
            .Font.Name = &quot;Verdana&quot;
            For n = 1 To text1_len
                If .Characters(n, 1) <> &quot; &quot; Then
                  h = 360 / text1_len * n
                  Call hsb2rgb(h, 0.8, 0.8)
                  .Characters(n, 1).Font.Color.RGB = RGB(r, g, bl)
                End If
            Next
      End With
End With
With shp_tmp.AnimationSettings '为隐藏形状添加自动动画
    .EntryEffect = ppEffectAppear
    .AdvanceMode = ppAdvanceOnTime
    .AdvanceTime = 0
    .Animate = msoTrue
End With
With Sld.TimeLine.MainSequence '为主形状添加字母动画
    .ConvertToTextUnitEffect .AddEffect(Shp, msoAnimEffectSwivel), msoAnimTextUnitEffectByCharacter '添加字母动画
    .Item(2).Timing.Duration = 1 '如果程序将添加大量形状执行大量动画的时候，item(X)还需要另外求呢。
    .Item(2).Timing.TriggerType = msoAnimTriggerAfterPrevious '设为跟随上一个动画播放
End With
End Sub
Sub hsb2rgb(h As Integer, s As Single, br As Single)
    Dim hi As Integer, p As Single, q As Single, t As Single, f As Single, v As Single
    v = br
    If v = 0 Then r = g = bl = 0: Exit Sub
    If s = 0 Then r = g = bl = v * 255: Exit Sub
    hi = Int(h / 60)
    f = h / 60 - hi
    p = v * (1 - s)
    q = v * (1 - s * f)
    t = v * (1 - s * (1 - f))
    Select Case hi
    Case 0
      r = v * 255: g = t * 255: bl = p * 255
    Case 1
      r = q * 255: g = v * 255: bl = p * 255
    Case 2
      r = p * 255: g = v * 255: bl = t * 255
    Case 3
      r = p * 255: g = q * 255: bl = v * 255
    Case 4
      r = t * 255: g = p * 255: bl = v * 255
    Case 5
      r = v * 255: g = p * 255: bl = q * 255
    End Select
End Sub
页: [1] 2
查看完整版本: 请问如何用VBA更改动画文本按字母延时百分比