Re: поиск PowerClip и в его содержимом

Написал wOxxOm в 25/02/2010 19:34:02

я использую подход для перебора поверклипов без рекурсивной функции, что есть хорошо.

Dim sr As ShapeRange, sr2 As ShapeRange, sh As Shape, pageIdx&

Set sr = New ShapeRange: Set sr2 = New ShapeRange

For pageIdx = 1 To ActiveDocument.Pages.Count
   sr.AddRange ActiveDocument.Pages(pageIdx).FindShapes
   
   Do
      For Each sh In sr
         '..................
         'проверки
         '..................
         If Not sh.PowerClip Is Nothing Then sr2.AddRange sh.PowerClip.shapes.FindShapes
      Next sh
      
      sr.RemoveAll: sr.AddRange sr2: sr2.RemoveAll
   Loop Until sr.Count = 0
Next pageIdx

а для проверок цветов градиента что-нибудь вроде такого:

Sub CheckOverprint()
   Dim sr As ShapeRange, sr2 As ShapeRange, sh As Shape, pageIdx&
   
   On Error Resume Next
   Set sr = New ShapeRange: Set sr2 = New ShapeRange
   
   For pageIdx = 1 To ActiveDocument.Pages.Count
      sr.AddRange ActiveDocument.Pages(pageIdx).FindShapes
      
      Do 'перебор поверклипов
         For Each sh In sr 'перебор шейпов
            
            If sh.OverprintOutline And sh.Outline.Type <> cdrNoOutline Then
               If sh.Outline.Color.IsSpot Then
                     'спотовый цвет на обводке оверпринтом
               End If
            End If
            
            If sh.OverprintFill Then
               
               Select Case sh.Fill.Type
                  Case cdrUniformFill
                     If sh.Fill.UniformColor.IsSpot Then
                        'спотовый цвет на заливке оверпринтом
                     End If
               
                  Case cdrFountainFill
                     'проверяем на цвета градиента
                     For i = 0 To sh.Fill.Fountain.Colors.Count + 1 'в массиве два доп. индекса для начала и конца градиента
                        If sh.Fill.Fountain.StartColor.IsSpot Then
                           'найден спотовый цвет
                        End If
                     Next
               End Select
            End If
            
            If Not sh.PowerClip Is Nothing Then
               'найден powerclip, добавляем содержимое в дальнейший перебор
               sr2.AddRange sh.PowerClip.shapes.FindShapes
            End If
         Next sh
         
         'пополняем основной список для перебора найденными powerclip'ами
         sr.RemoveAll: sr.AddRange sr2: sr2.RemoveAll
      Loop Until sr.Count = 0
   Next pageIdx
   
End Sub

p.s. да, кстати... в ВБА никогда не следует объявлять ShapeRange, Collection через слово NEW (Dim sr as new shaperange), т.к. из-за глюка вба доступ к таким массивам тормозится раз в 2-10 при обработке сложных многообъектных макетов.