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循环中删除它们，结果将不是您所期望的。

如果删除形状，您可以使用以下内容：

对于x = sld.Shapes.Count为1步-1 '如果符合您的条件，请删除sld.Shapes（x）下一步

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

Answer 2

史蒂夫 - 你的反应让我更接近，但我仍然犯了新手的错误。下面是我尝试将句柄存储到动态数组中，然后提取它们以设置透明度和ZOrder。看起来我的前面每个循环都在一张幻灯片上工作，然后可能是一个空条目。我尝试更改数组的初始大小并添加一个ON错误陷阱，最后添加＆＃34;如果wshp.Type＆＃34;测试，但我得到错误或运行时错误＆＃34;对象变量或没有设置块变量＆＃34;在wshp.Fill和wshp.ZOrder命令上。

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
                'shp.Fill.Transparency = 0
                'shp.ZOrder msoSendToBack
                'shp.Fill.Transparency = 0.75
                'shp.ZOrder msoBringToFront
              End If
              If shp.TextFrame.TextRange = "wipeb" Then
                Set wshps(i) = shp
                i = i + 1
                ReDim Preserve wshps(0 To i) As Shape
                'shp.Fill.Transparency = 0
                'shp.ZOrder msoSendToBack
                'shp.Fill.Transparency = 0.75
                'shp.ZOrder msoBringToFront
              End If
            End If
        End If
    Next shp
    For Each wshp In wshps
      If wshp.Type = msoAutoShape Then
      'On Error GoTo ErrorHandler
      wshp.Fill.Transparency = 0.75
      wshp.ZOrder msoBringToFront
      'Exit Sub
      End If
    Next wshp
  Next sld

'ErrorHandler:   Resume Next
  End Sub

Answer 3

好的，明白了！ 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跳过一些有效的形状

3 个答案: