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

docxueruizhi

在没有调整的情况下，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

动画效果很不错，但要正常运行好象要修改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

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

user_pdhvlzfc

变通处理啊，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

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

user_yculd

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

ytyujia

可惜。这本来是要写在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:00  201"
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

学习下，PPT刚接触

fafa68868

终于可以实现了：
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:00  201&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

非常感谢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:00  201&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