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

Я делаю презентации со вытеснением фона, которые представляют собой фигуры процесса блок-схемы с текстом «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

vba transparency powerpoint textrange
person Cliff Cummings    schedule 25.05.2018    source источник

Ответы (2)


arrow_upward
1
arrow_downward

Если вы измените порядок фигур (как это происходит при изменении z-порядка) или удалите их посреди цикла For Each/Next, результаты будут не такими, как вы ожидаете.

Если вы удаляете фигуры, вы можете использовать что-то вроде этого:

For x = sld.Shapes.Count to 1 Шаг -1 'удалить sld.Shapes(x), если он соответствует вашим условиям. Далее

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

person Steve Rindsberg    schedule 25.05.2018
comment
Привет, Стив. Ваш ответ приближает меня, но я все еще делаю ошибки новичка. Ниже моя попытка сохранить дескрипторы в динамический массив, а затем извлечь их, чтобы установить прозрачность и ZOrder. - person Cliff Cummings; 25.05.2018

arrow_upward
0
arrow_downward

Хорошо, понял! Стив Риндсберг указал мне правильное направление, и я исправил «Возобновить дальше при ошибке», и теперь подпрограммы делают то, что ожидалось. Спасибо за помощь!

Протрите фронт():

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

Протрите_Назад():

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
person Cliff Cummings    schedule 25.05.2018
comment
Поздравляем! - person Steve Rindsberg; 27.05.2018