Powerpoint VBA foreach 跳过一些有效的形状

Question

我用背景擦拭布做演示，这些背景擦拭布是流程图处理形状，文本 "wipey" 表示黄色擦拭布，"wipeb" 表示蓝色擦拭布。在制作培训幻灯片的动画时，我将擦拭物放在前面，透明度为 0.75。擦除动画顺序正确且擦除位置正确后，我将擦除移动到透明度为 0 的文本后面。我的 Wipe_Back 宏工作正常，但我的 Wipe_Front 宏在每次调用时只会擦除一些内容。我必须多次调用它才能使所有形状向前移动。宏几乎相同，所以我不确定自己做错了什么，但我是 VBA 新手！这两个宏都显示在下面，我也愿意接受有关代码中更优雅实践的建议。

Wipe_Back（似乎有效）：

Sub Wipe_Back()
  Dim sld As slide
  Dim shp As Shape
  Dim str As String
  For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.Type = msoAutoShape Then
            If shp.HasTextFrame Then
              If shp.TextFrame.TextRange = "wipey" Then
                shp.Fill.Transparency = 0
                shp.ZOrder msoSendToBack
                'shp.Fill.Transparency = 0.75
                'shp.ZOrder msoBringToFront
              End If
              If shp.TextFrame.TextRange = "wipeb" Then
                shp.Fill.Transparency = 0
                shp.ZOrder msoSendToBack
                'shp.Fill.Transparency = 0.75
                'shp.ZOrder msoBringToFront
              End If
            End If
        End If
    Next shp
  Next sld
End Sub

Wipe_Front 不始终有效：

Sub Wipe_Front()
  Dim sld As slide
  Dim shp As Shape
  Dim str As String
  For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.Type = msoAutoShape Then
            If shp.HasTextFrame Then
              If shp.TextFrame.TextRange = "wipey" Then
                'shp.Fill.Transparency = 0
                'shp.ZOrder msoSendToBack
                shp.Fill.Transparency = 0.75
                shp.ZOrder msoBringToFront
              End If
              If shp.TextFrame.TextRange = "wipeb" Then
                'shp.Fill.Transparency = 0
                'shp.ZOrder msoSendToBack
                shp.Fill.Transparency = 0.75
                shp.ZOrder msoBringToFront
              End If
            End If
        End If
    Next shp
  Next sld
End Sub

Answer 1

如果您更改形状的顺序（如更改 z 顺序）或在 For Each/Next 循环中删除它们，结果将不是您所期望的。

如果要删除形状，可以这样使用：

For x = sld.Shapes.Count to 1 Step -1 ' 如果 sld.Shapes(x) 符合你的条件就删除下一个

如果更改 z 顺序，您可能需要收集对数组中形状的引用，并一次逐个遍历数组中的一个形状。

Answer 2

好的，知道了！ Steve Rindsberg 为我指明了正确的方向，我更正了 "On Error Resume Next"，现在例程正在按预期进行。感谢您的帮助！

擦前():

Sub Wipe_Front()
  Dim sld As slide
  Dim shp As Shape
  Dim str As String
  Dim wshps() As Shape, i As Long
  ReDim wshps(0 To 1)
  i = 0

  For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.Type = msoAutoShape Then
            If shp.HasTextFrame Then
              If shp.TextFrame.TextRange = "wipey" Then
                Set wshps(i) = shp
                i = i + 1
                ReDim Preserve wshps(0 To i) As Shape
              End If
              If shp.TextFrame.TextRange = "wipeb" Then
                Set wshps(i) = shp
                i = i + 1
                ReDim Preserve wshps(0 To i) As Shape
              End If
            End If
        End If
    Next shp
    For Each wshp In wshps
      On Error Resume Next
      wshp.Fill.Transparency = 0.75
      wshp.ZOrder msoBringToFront
      'wshp.Fill.Transparency = 0
      'wshp.ZOrder msoSendToBack
    Next wshp
  Next sld
End Sub

Wipe_Back():

Sub Wipe_Back_New()
  Dim sld As slide
  Dim shp As Shape
  Dim str As String
  Dim wshps() As Shape, i As Long
  ReDim wshps(0 To 1)
  i = 0

  For Each sld In ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.Type = msoAutoShape Then
            If shp.HasTextFrame Then
              If shp.TextFrame.TextRange = "wipey" Then
                Set wshps(i) = shp
                i = i + 1
                ReDim Preserve wshps(0 To i) As Shape
              End If
              If shp.TextFrame.TextRange = "wipeb" Then
                Set wshps(i) = shp
                i = i + 1
                ReDim Preserve wshps(0 To i) As Shape
              End If
            End If
        End If
    Next shp
    For Each wshp In wshps
      On Error Resume Next
      'wshp.Fill.Transparency = 0.75
      'wshp.ZOrder msoBringToFront
      wshp.Fill.Transparency = 0
      wshp.ZOrder msoSendToBack
    Next wshp
  Next sld
End Sub

Powerpoint VBA foreach 跳过一些有效的形状

Powerpoint VBA foreach skipping some valid shapes

powerpoint

transparency

vba

textrange