Question

我有一个2500个中文单词的excel文件，我想用VBA转换成PPT演示文稿。由于中文是一种有声调的语言，因此我想让字符根据其音调（从1-5开始）更改颜色。我将形状添加到演示文稿并正确设置格式没有问题。我总共需要添加五个动画，并且其中四个可以完美运行（淡入，淡出，淡入，淡入）。唯一的问题是更改汉字的字体颜色动画。

我创建了一个shaperange，其中包含所有可能的形状名称（“ HZ1”，“ HZ2”，“ HZ3”，“ HZ4”，“ HZ5”），然后重新命名以保留正确数量的形状。 if语句将检查我excel文件中的相应单元格，以检查要使用的色调并根据该色调设置color2。如果shaperange包含3个或更少的形状，则整个过程将顺利进行，它将正确设置动画颜色。但是，如果shaperange包含4或5个形状，则仅适用于前三个形状，而形状4和5仍会添加动画，但无法设置正确的颜色（取而代之的是橙色）。我不知道是什么原因导致此错误，希望能得到我的帮助。

    Sub AnimationLoop()


Dim finalrow As Integer 'final row
Dim pyArray As Variant
Dim ptArray As Variant
Dim hzArray As Variant
Dim i As Integer 'row counter
Dim j As Integer 'Used in if loop
Dim k As Integer 'Used in if loop
Dim l As Integer 'counting number of shapes
Dim m As Integer 'Makes color change to corresponding shape
Dim n As Integer 'starting point
Dim w As Long 'width
Dim start As Long
Dim mid As Long

Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShape As PowerPoint.Shape
Dim oShp As PowerPoint.Shape 'Audio File
Dim sEff As PowerPoint.Effect
Dim sEff1 As PowerPoint.Effect
Dim shp As PowerPoint.Shape
Dim shpRng1 As PowerPoint.ShapeRange
Dim shpRng2 As PowerPoint.ShapeRange
Dim shpRng3 As PowerPoint.ShapeRange




'This is where Shapes are added (omitted for github)
 'Animations follow


l = (Cells(i, 18) - 1)
pyArray = Array("PY1", "PY2", "PY3", "PY4", "PY5")
ReDim Preserve pyArray(l)
ptArray = Array("PT1", "PT2", "PT3", "PT4", "PT5")
ReDim Preserve ptArray(l)
hzArray = Array("HZ1", "HZ2", "HZ3", "HZ4", "HZ5")
ReDim Preserve hzArray(l)

Set shpRng1 = mySlide.Shapes.Range(pyArray) 'Pinyin Animation
For Each shp In shpRng1
    Set sEff = mySlide.TimeLine.MainSequence.AddEffect(Shape:=shp, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerWithPrevious) 'Fade in
    With sEff
        .Timing.Duration = 0.5
        .Timing.TriggerDelayTime = 3
    End With
    Set sEff = mySlide.TimeLine.MainSequence.AddEffect(Shape:=shp, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerWithPrevious) 'Fade out
    With sEff
        .Exit = msoTrue
        .Timing.Duration = 0.25
        .Timing.TriggerDelayTime = 5.75
    End With
Next shp

Set shpRng2 = mySlide.Shapes.Range(ptArray) 'Tones Animation
For Each shp In shpRng2
    Set sEff = mySlide.TimeLine.MainSequence.AddEffect(Shape:=shp, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerWithPrevious) 'Fade in
    With sEff
        .Timing.Duration = 0.5
        .Timing.TriggerDelayTime = 6
    End With
Next shp


'THIS IS WHERE THE PROBLEM IS
'THIS IS WHERE THE PROBLEM IS

Set shpRng3 = mySlide.Shapes.Range(hzArray) 'Hanzi Animation
m = 1
For Each shp In shpRng3
    Debug.Print "m:"; m
    Set sEff = mySlide.TimeLine.MainSequence.AddEffect(Shape:=shp, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerWithPrevious) 'Fade in
    With sEff
        .Timing.Duration = 0.5
        .Timing.TriggerDelayTime = 1
    End With

    Set sEff1 = mySlide.TimeLine.MainSequence.AddEffect(Shape:=shp, effectid:=msoAnimEffectChangeFontColor, trigger:=msoAnimTriggerWithPrevious) 'Change color font
    With sEff1
        If Cells(i, 10 + m) = "1" Then
            .EffectParameters.Color2.RGB = RGB(255, 0, 0)
        ElseIf Cells(i, 10 + m) = "2" Then
            .EffectParameters.Color2.RGB = RGB(112, 173, 71)
        ElseIf Cells(i, 10 + m) = "3" Then
            .EffectParameters.Color2.RGB = RGB(16, 123, 240)
        ElseIf Cells(i, 10 + m) = "4" Then
            .EffectParameters.Color2.RGB = RGB(141, 66, 198)
        ElseIf Cells(i, 10 + m) = "5" Then
            .EffectParameters.Color2.RGB = RGB(142, 142, 142)
        Else
            .EffectParameters.Color2.RGB = RGB(255, 255, 255)
        End If
        .Timing.Duration = 0.5
        .Timing.TriggerDelayTime = 6
    End With
    m = m + 1
Next shp

在shaperange中更改字体颜色效果仅适用于前三个（四个或五个）形状。如何解决？

0 个答案: