Powerpoint VBA foreach пропускает некоторые допустимые формы - PullRequest
Новая
       42

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

0 голосов
/ 25 мая 2018

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

Ответы [ 3 ]

0 голосов
/ 25 мая 2018

Стив - ваш ответ приближает меня, но я все еще делаю ошибки новичка.Ниже моя попытка сохранить дескрипторы в динамический массив, а затем извлечь их, чтобы установить прозрачность и 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
0 голосов
/ 25 мая 2018

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

Wipe Front (): 

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
0 голосов
/ 25 мая 2018

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

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

Для x = sld.Shapes.Count to 1 Step -1 'delete sld.Shapes (x), если это удовлетворяет вашим условиям Далее

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

...