Hi. I'm trying to make a macro that will search a document and list all instances of transparency objects in each page.
Ive started with this code but I'm sure it's missing some things.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
Private Sub CommandButton1_Click() Optimization = True ActiveDocument.BeginCommandGroup Dim sr As ShapeRange, s As Shape Set sr = ActivePage.FindShapes() If sr.count = 0 Then MsgBox "No Lens objects found." Exit Sub End If For Each s In sr If s.Transparency.Type <> cdrNoTransparency Then s.Transparency.ApplyNoTransparency Next ActiveDocument.EndCommandGroup Optimization = False End Sub
You might be able to modify this?
[CODE]
Public Sub FindTrans()
Dim sr As ShapeRange, s As Shape, eff As EffectDim i&Dim sr2 As New ShapeRange
For i = 1 To ActiveDocument.Pages.count Set sr = ActiveDocument.Pages(i).Shapes.All For Each s In sr If s.Transparency.Type = cdrUniformTransparency Then _ MsgBox "Found " For Each eff In s.Effects If eff.Lens.Type = cdrLensTransparency Then eff.Clear 'clears effects sr2.Add s 'add to the 2nd shaperange to allow selection at the end End If
Next eff Next sNext i
sr2.CreateSelection
[/CODE]
For me cdrLensTransparency did not work...
Sub ClearLens()
Dim sr As ShapeRange, s As Shape, eff As Effect, i&
ActiveDocument.BeginCommandGroup "Clear lens"
For i = 1 To ActiveDocument.Pages.CountSet sr = ActiveDocument.Pages(i).Shapes.All
For Each s In sr
For Each eff In s.EffectsIf Not s.Effects.LensEffect Is Nothing Theneff.Clear 'clears effectsEnd IfNext eff
Next sNext iActiveDocument.EndCommandGroup
End Sub
You can use CQL to find the shapes. Then loop your ShapeRange to output a list.
Sub FindTransparency() Dim srTransparency As ShapeRange, s As Shape Dim p As Page For Each p In ActiveDocument.Pages Set srTransparency = p.Shapes.FindShapes(Query:="@com.transparency.type <> 0") For Each s In srTransparency.Shapes Debug.Print s.StaticID Next s Next p End Sub
I tried all of these methods and not luck.
In which version of CorelDRAW are you testing these codes?