Powerpoint VBA foreach пропускает некоторые допустимые формы

Question

Я делаю презентации с фоновыми вайпами, которые представляют собой формы процесса на блок-схеме с текстом "wipey" для желтых салфеток и "wipeb" для синих салфеток. При разработке анимации для учебных слайдов я размещаю вайпы впереди с прозрачностью 0,75. Как только порядок анимации вытирается правильно, а вытирание правильно размещено, я перемещаю вайпы за текстом с нулевой прозрачностью. Мой макрос 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 to 1 Step -1 'удалите sld.Shapes(x), если оно соответствует вашим условиям Далее

При изменении z-порядка вам может потребоваться собрать ссылки на фигуры в массиве и шаг за шагом проходить по массиву фигуры.

Answer 2

Хорошо, понял! Стив Риндсберг указал мне правильное направление, и я исправил "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

Answer 3

Стив - твой ответ приближает меня, но я все еще делаю ошибки новичка. Ниже моя попытка сохранить дескрипторы в динамический массив, а затем извлечь их, чтобы установить прозрачность и ZOrder. Похоже, что каждый цикл работает над одним слайдом, а затем, вероятно, получает пустую запись. Я попытался изменить начальный размер массива и добавить ловушку ON Error и, наконец, тест "if wshp.Type", но я либо получаю ошибки, либо ошибку времени выполнения "Переменная объекта или С переменной блока не установлено" на Команды 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